From ac1440c1893b12107f916571145ecc0723a6e20b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 1 Jul 2025 15:13:10 +0900 Subject: [PATCH 001/184] feat: adding FEVariable_ToString and ToInteger methods Enhance the FEVariable module by implementing new getter methods in FEVariable_Method.F90 and its associated submodule. These changes improve the module's API by providing more consistent and robust data access capabilities. --- .../FEVariable/src/FEVariable_Method.F90 | 34 +++++++- .../src/FEVariable_Method@GetMethods.F90 | 85 +++++++++++++++---- 2 files changed, 101 insertions(+), 18 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 718aba242..9f37cb026 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -57,6 +57,8 @@ MODULE FEVariable_Method PUBLIC :: MEAN PUBLIC :: GetLambdaFromYoungsModulus PUBLIC :: ASSIGNMENT(=) +PUBLIC :: FEVariable_ToString +PUBLIC :: FEVariable_ToInteger INTEGER(I4B), PARAMETER :: CAPACITY_EXPAND_FACTOR = 1 ! capacity = tsize * CAPACITY_EXPAND_FACTOR @@ -877,7 +879,7 @@ END FUNCTION Nodal_Matrix_SpaceTime2 END INTERFACE NodalVariable !---------------------------------------------------------------------------- -! Assignment@ConstructorMethods +! Assignment@ConstructorMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -891,6 +893,36 @@ MODULE PURE SUBROUTINE obj_Copy(obj1, obj2) END SUBROUTINE obj_Copy END INTERFACE +!---------------------------------------------------------------------------- +! FEVariable_ToString@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-07-01 +! summary: Converts scalar, vector, matrix to string name + +INTERFACE + MODULE PURE FUNCTION FEVariable_ToString(name) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: name + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION FEVariable_ToString +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 !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 index dc39463e2..9e6b81e6d 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 @@ -15,15 +15,63 @@ ! along with this program. If not, see SUBMODULE(FEVariable_Method) GetMethods - USE ReallocateUtility, ONLY: Reallocate -USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & - Time, SpaceTime, Nodal, Quadrature +USE BaseType, ONLY: feopt => TypeFEVariableOpt + IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! FEVariable_ToString +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FEVariable_ToString + +SELECT CASE (name) +CASE (feopt%scalar) + ans = "SCALAR" + +CASE (feopt%vector) + ans = "VECTOR" + +CASE (feopt%matrix) + ans = "MATRIX" + +CASE DEFAULT + ans = "SCALAR" + +END SELECT + +END PROCEDURE FEVariable_ToString + +!---------------------------------------------------------------------------- +! 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 !---------------------------------------------------------------------------- @@ -59,33 +107,36 @@ MODULE PROCEDURE fevar_Shape SELECT CASE (obj%rank) -CASE (Scalar) +CASE (feopt%scalar) SELECT CASE (obj%vartype) - CASE (Constant) + CASE (feopt%constant) ans = [1] - CASE (Space, Time) + CASE (feopt%space, feopt%time) ans = obj%s(1:1) - CASE (SpaceTime) + CASE (feopt%spaceTime) ans = obj%s(1:2) END SELECT -CASE (Vector) + +CASE (feopt%vector) SELECT CASE (obj%vartype) - CASE (Constant) + CASE (feopt%constant) ans = obj%s(1:1) - CASE (Space, Time) + CASE (feopt%space, feopt%time) ans = obj%s(1:2) - CASE (SpaceTime) + CASE (feopt%spaceTime) ans = obj%s(1:3) END SELECT -CASE (Matrix) + +CASE (feopt%matrix) SELECT CASE (obj%vartype) - CASE (Constant) + CASE (feopt%constant) ans = obj%s(1:2) - CASE (Space, Time) + CASE (feopt%space, feopt%time) ans = obj%s(1:3) - CASE (SpaceTime) + CASE (feopt%spaceTime) ans = obj%s(1:4) END SELECT + END SELECT END PROCEDURE fevar_Shape @@ -118,7 +169,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_isNodalVariable -ans = obj%defineon .EQ. nodal +ans = obj%defineon .EQ. feopt%nodal END PROCEDURE fevar_isNodalVariable !---------------------------------------------------------------------------- @@ -126,7 +177,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_isQuadratureVariable -ans = obj%defineon .NE. nodal +ans = obj%defineon .NE. feopt%nodal END PROCEDURE fevar_isQuadratureVariable !---------------------------------------------------------------------------- From 356be60fb584f2b83a2c33c5732243635ec4724d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 1 Jul 2025 16:57:46 +0900 Subject: [PATCH 002/184] feat(QuadraturePoint): expose QuadraturePointNameToId through QuadraturePoint_ToInteger interface Make the QuadraturePointNameToId function publicly accessible via the QuadraturePoint_ToInteger interface and add it to the PUBLIC list. --- src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 2d288dd6d..1f23017ac 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -45,6 +45,7 @@ MODULE QuadraturePoint_Method ! PUBLIC :: QuadraturePoint_MdEncode PUBLIC :: QuadraturePointIdToName PUBLIC :: QuadraturePoint_ToChar +PUBLIC :: QuadraturePoint_ToInteger PUBLIC :: QuadraturePointNameToId PUBLIC :: MdEncode @@ -56,12 +57,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 From 5c454ab14af581f48445cf8d5333e8734cf5b620 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 1 Jul 2025 16:58:53 +0900 Subject: [PATCH 003/184] feat(FEVariable): rename FEVariable_ToString to FEVariable_ToChar with case control The FEVariable_ToString function has been renamed to FEVariable_ToChar for consistency with naming conventions. Added an optional 'isUpper' parameter to control text case output. Default output is now in Title Case instead of uppercase, with the ability to convert to uppercase when needed. --- .../FEVariable/src/FEVariable_Method.F90 | 9 +++++---- .../src/FEVariable_Method@GetMethods.F90 | 19 +++++++++++++------ 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 9f37cb026..acb6bd72b 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -57,7 +57,7 @@ MODULE FEVariable_Method PUBLIC :: MEAN PUBLIC :: GetLambdaFromYoungsModulus PUBLIC :: ASSIGNMENT(=) -PUBLIC :: FEVariable_ToString +PUBLIC :: FEVariable_ToChar PUBLIC :: FEVariable_ToInteger INTEGER(I4B), PARAMETER :: CAPACITY_EXPAND_FACTOR = 1 @@ -894,7 +894,7 @@ END SUBROUTINE obj_Copy END INTERFACE !---------------------------------------------------------------------------- -! FEVariable_ToString@GetMethods +! FEVariable_ToChar@GetMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -902,10 +902,11 @@ END SUBROUTINE obj_Copy ! summary: Converts scalar, vector, matrix to string name INTERFACE - MODULE PURE FUNCTION FEVariable_ToString(name) RESULT(ans) + MODULE PURE FUNCTION FEVariable_ToChar(name, isUpper) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION FEVariable_ToString + LOGICAL(LGT), INTENT(IN), OPTIONAL :: isUpper + END FUNCTION FEVariable_ToChar END INTERFACE !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 index 9e6b81e6d..c7371d23e 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 @@ -16,6 +16,7 @@ SUBMODULE(FEVariable_Method) GetMethods USE ReallocateUtility, ONLY: Reallocate +USE StringUtility, ONLY: UpperCase USE BaseType, ONLY: feopt => TypeFEVariableOpt @@ -27,24 +28,30 @@ ! FEVariable_ToString !---------------------------------------------------------------------------- -MODULE PROCEDURE FEVariable_ToString +MODULE PROCEDURE FEVariable_ToChar SELECT CASE (name) CASE (feopt%scalar) - ans = "SCALAR" + ans = "Scalar" CASE (feopt%vector) - ans = "VECTOR" + ans = "Scalar" CASE (feopt%matrix) - ans = "MATRIX" + ans = "Matrix" CASE DEFAULT - ans = "SCALAR" + ans = "Scalar" END SELECT -END PROCEDURE FEVariable_ToString +IF (PRESENT(isUpper)) THEN + IF (isUpper) THEN + ans = UpperCase(ans) + END IF +END IF + +END PROCEDURE FEVariable_ToChar !---------------------------------------------------------------------------- ! FEVariable_ToInteger From 33e58ff7969d9c6da3b5f523810d528b10f650b0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 10 Jul 2025 10:24:04 +0900 Subject: [PATCH 004/184] refactor(DOF): improve DOF display procedures - Add explicit allocation check with early return in dof_Display1 - Remove ASSOCIATE block in favor of direct object access - Simplify control flow with more linear structure - Remove "# " prefixes from display messages - Improve code formatting and spacing for readability --- .../DOF/src/DOF_IOMethods@Methods.F90 | 71 ++++++++++--------- 1 file changed, 39 insertions(+), 32 deletions(-) diff --git a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 index 5fda02d7e..053ad9e57 100644 --- a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 +++ b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 @@ -30,35 +30,39 @@ MODULE PROCEDURE dof_Display1 INTEGER(I4B) :: n, j +LOGICAL(LGT) :: isok + +CALL Display(msg, unitNo=unitNo) + +isok = ALLOCATED(obj%map) +CALL Display(isok, "obj%map allocated: ", UnitNo=UnitNo) +IF (.NOT. isok) RETURN + +n = SIZE(obj%map, 1) - 1 +CALL Display(n, "Total Physical Variables :", unitNo=unitNo) + +DO j = 1, n + CALL Display("Name : "//CHAR(obj%map(j, 1)), unitNo=unitNo) + + IF (obj%map(j, 2) .LT. 0) THEN + CALL Display("Space Components : "//"Scalar", unitNo=unitNo) + ELSE + CALL Display(obj%map(j, 2), "Space Components : ", unitNo=unitNo) + END IF + + CALL Display(obj%map(j, 3), "Time Components : ", unitNo=unitNo) + CALL Display(obj%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) -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 !---------------------------------------------------------------------------- @@ -68,14 +72,17 @@ 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 Display(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") + CALL Display(Vec(a(1):a(2):a(3)), & + msg="DOF-"//TOSTRING(idof), unitNo=unitNo, advance="NO") END DO CALL Display(" ", unitNo=unitNo, advance=.TRUE.) END DO From 8284ec02948d115723e76a70ca9d605203a45f03 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 10 Jul 2025 10:24:35 +0900 Subject: [PATCH 005/184] fix(Geometry): standardize ElementName capitalization - Rename "Elementname" to "ElementName" for consistent capitalization - Update all interface declarations and related comments - Maintain consistent naming conventions across the codebase - Fix lowercase "n" in all occurrences of ElementName in ReferenceElement_Method.F90 --- .../Geometry/src/ReferenceElement_Method.F90 | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index dae820c5f..f33c6cf3c 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -39,7 +39,7 @@ MODULE ReferenceElement_Method PUBLIC :: ReferenceElement_Pointer PUBLIC :: GetConnectivity PUBLIC :: ElementType -PUBLIC :: Elementname +PUBLIC :: ElementName PUBLIC :: TotalNodesInElement PUBLIC :: ElementOrder PUBLIC :: OPERATOR(.order.) @@ -690,7 +690,7 @@ END FUNCTION refelem_Getnptrs END INTERFACE GetConnectivity !---------------------------------------------------------------------------- -! ElementType@ElementnameMethods +! ElementType@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -705,7 +705,7 @@ END FUNCTION Element_Type END INTERFACE ElementType !---------------------------------------------------------------------------- -! ElementType@ElementnameMethods +! ElementType@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -720,37 +720,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. @@ -765,7 +765,7 @@ END FUNCTION Total_Nodes_In_Element END INTERFACE TotalNodesInElement !---------------------------------------------------------------------------- -! ElementOrder@ElementnameMethods +! ElementOrder@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -780,7 +780,7 @@ END FUNCTION Element_Order END INTERFACE ElementOrder !---------------------------------------------------------------------------- -! ElementOrder@ElementnameMethods +! ElementOrder@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -799,7 +799,7 @@ END FUNCTION Element_Order_refelem END INTERFACE OPERATOR(.order.) !---------------------------------------------------------------------------- -! XiDimension@ElementnameMethods +! XiDimension@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -815,7 +815,7 @@ END FUNCTION Elem_XiDimension1 END INTERFACE Xidimension !---------------------------------------------------------------------------- -! Xidimension@ElementnameMethods +! Xidimension@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1161,7 +1161,7 @@ END FUNCTION isSerendipityElement2 END INTERFACE isSerendipityElement !---------------------------------------------------------------------------- -! ElementTopology@ElementnameMethods +! ElementTopology@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1189,7 +1189,7 @@ END FUNCTION refelem_ElementTopology1 END INTERFACE OPERATOR(.topology.) !---------------------------------------------------------------------------- -! ElementTopology@ElementnameMethods +! ElementTopology@ElementNameMethods !---------------------------------------------------------------------------- INTERFACE ElementTopology From 7c4242e0a2c921c3f9e51c57816f1c849fb69453 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 24 Jul 2025 07:44:12 +0900 Subject: [PATCH 006/184] minor formatting in reallocate --- src/modules/Utility/src/ReallocateUtility.F90 | 65 ++++++++++++------- 1 file changed, 43 insertions(+), 22 deletions(-) diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90 index 8d9f989f7..08bcb9b63 100644 --- a/src/modules/Utility/src/ReallocateUtility.F90 +++ b/src/modules/Utility/src/ReallocateUtility.F90 @@ -111,7 +111,8 @@ END SUBROUTINE Reallocate_Real32_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R2(mat, row, col, isExpand, expandFactor) + 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 @@ -143,7 +144,8 @@ END SUBROUTINE Reallocate_Real64_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R2(mat, row, col, isExpand, expandFactor) + 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 @@ -175,7 +177,8 @@ END SUBROUTINE Reallocate_Real32_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R3(mat, i1, i2, i3, isExpand, expandFactor) + 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 @@ -207,7 +210,8 @@ END SUBROUTINE Reallocate_Real64_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R3(mat, i1, i2, i3, isExpand, expandFactor) + 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 @@ -239,7 +243,8 @@ END SUBROUTINE Reallocate_Real32_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + 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 @@ -271,7 +276,8 @@ END SUBROUTINE Reallocate_Real64_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + 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 @@ -303,7 +309,8 @@ END SUBROUTINE Reallocate_Real32_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor) + 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 @@ -335,7 +342,8 @@ END SUBROUTINE Reallocate_Real64_R5b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor) + 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 @@ -400,7 +408,8 @@ END SUBROUTINE Reallocate_Real64_R6b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R6(mat, i1, i2, i3, i4, i5, i6, isExpand, expandFactor) + 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 @@ -630,7 +639,8 @@ END SUBROUTINE Reallocate_Int8_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R2(mat, row, col, isExpand, expandFactor) + 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 @@ -650,7 +660,8 @@ MODULE PURE SUBROUTINE Reallocate_Int64_R2b(mat, s, isExpand, expandFactor) INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R2b - MODULE PURE SUBROUTINE Reallocate_Int32_R2(mat, row, col, isExpand, expandFactor) + 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 @@ -670,7 +681,8 @@ MODULE PURE SUBROUTINE Reallocate_Int32_R2b(mat, s, isExpand, expandFactor) INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R2b - MODULE PURE SUBROUTINE Reallocate_Int16_R2(mat, row, col, isExpand, expandFactor) + 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 @@ -690,7 +702,8 @@ MODULE PURE SUBROUTINE Reallocate_Int16_R2b(mat, s, isExpand, expandFactor) INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int16_R2b - MODULE PURE SUBROUTINE Reallocate_Int8_R2(mat, row, col, isExpand, expandFactor) + 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 @@ -716,7 +729,8 @@ END SUBROUTINE Reallocate_Int8_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R3(mat, i1, i2, i3, isExpand, expandFactor) + 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 @@ -748,7 +762,8 @@ END SUBROUTINE Reallocate_Int64_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R3(mat, i1, i2, i3, isExpand, expandFactor) + 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 @@ -780,8 +795,8 @@ END SUBROUTINE Reallocate_Int32_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R4(mat, i1, & - i2, i3, i4, isExpand, expandFactor) + 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 @@ -813,7 +828,8 @@ END SUBROUTINE Reallocate_Int64_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + 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 @@ -978,7 +994,7 @@ END SUBROUTINE Reallocate_Int32_R6b INTERFACE Reallocate MODULE PURE SUBROUTINE Reallocate_Int64_R7(mat, i1, i2, i3, i4, i5, & - & i6, i7, isExpand, expandFactor) + 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 @@ -1044,7 +1060,8 @@ 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, isExpand, expandFactor) + 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(:) @@ -1064,7 +1081,9 @@ 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, isExpand, expandFactor) + 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(:) @@ -1084,7 +1103,9 @@ 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, isExpand, expandFactor) + 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(:) From db5fd32915bd908543db19e13466c8faf112d306 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 24 Jul 2025 07:44:54 +0900 Subject: [PATCH 007/184] name changes in BaseInterpolation --- .../src/BaseInterpolation_Method.F90 | 65 ++++++++++--------- ...draturePoint_Method@ConstructorMethods.F90 | 15 ++--- 2 files changed, 40 insertions(+), 40 deletions(-) diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 index 7e424ed84..4afe02b7f 100644 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -40,26 +40,15 @@ MODULE BaseInterpolation_Method PUBLIC :: BaseInterpolation_FromInteger PUBLIC :: BaseInterpolation_FromString PUBLIC :: BaseInterpolationPointer_FromString -PUBLIC :: BaseType_ToInteger - PUBLIC :: BaseInterpolation_ToString -PUBLIC :: BaseType_ToChar PUBLIC :: BaseInterpolation_ToChar -INTERFACE BaseInterpolation_ToInteger - MODULE PROCEDURE BaseInterpolation_ToInteger1 - MODULE PROCEDURE BaseInterpolation_ToInteger2 -END INTERFACE BaseInterpolation_ToInteger - -INTERFACE BaseType_ToInteger - MODULE PROCEDURE BaseInterpolation_ToInteger1 - MODULE PROCEDURE BaseType_ToInteger1 -END INTERFACE BaseType_ToInteger +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 @@ -137,7 +126,7 @@ END SUBROUTINE BaseInterpolation_Copy ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) +FUNCTION BaseInterpolation_ToInteger(obj) RESULT(ans) CLASS(BaseInterpolation_), INTENT(IN) :: obj INTEGER(I4B) :: ans @@ -159,19 +148,19 @@ FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) CLASS DEFAULT CALL ErrorMsg(msg="NO CASE FOUND for type of obj2", & - routine="BaseInterpolation_toInteger()", & + routine="BaseInterpolation_ToInteger()", & line=__LINE__, unitno=stdout, file=__FILE__) STOP END SELECT -END FUNCTION BaseInterpolation_ToInteger1 +END FUNCTION BaseInterpolation_ToInteger !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -FUNCTION BaseType_ToInteger1(name) RESULT(ans) +FUNCTION BaseType_ToInteger(name) RESULT(ans) CHARACTER(*), INTENT(IN) :: name INTEGER(I4B) :: ans @@ -212,12 +201,12 @@ FUNCTION BaseType_ToInteger1(name) RESULT(ans) CASE DEFAULT CALL ErrorMsg(msg="NO CASE FOUND for name: "//astr, & - routine="BaseType_ToInteger1()", & + routine="BaseType_ToInteger()", & line=__LINE__, unitno=stdout, file=__FILE__) STOP END SELECT -END FUNCTION BaseType_ToInteger1 +END FUNCTION BaseType_ToInteger !---------------------------------------------------------------------------- ! BaseInterpolation_toInteger @@ -227,7 +216,7 @@ END FUNCTION BaseType_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 @@ -310,7 +299,7 @@ FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) END SELECT astr = "" -END FUNCTION BaseInterpolation_ToInteger2 +END FUNCTION InterpolationPoint_ToInteger !---------------------------------------------------------------------------- ! BaseInterpolation_fromInteger @@ -401,10 +390,21 @@ END SUBROUTINE BaseInterpolation_FromString ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -FUNCTION BaseInterpolation_ToString1(obj, isUpper) RESULT(ans) +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 + +!---------------------------------------------------------------------------- +! BaseInterpolation_ToChar +!---------------------------------------------------------------------------- + +FUNCTION BaseInterpolation_ToChar(obj, isUpper) RESULT(ans) + CLASS(BaseInterpolation_), INTENT(IN) :: obj + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper + CHARACTER(:), ALLOCATABLE :: ans ! internal variables LOGICAL(LGT) :: isUpper0 @@ -449,13 +449,14 @@ FUNCTION BaseInterpolation_ToString1(obj, isUpper) RESULT(ans) END IF CLASS DEFAULT + ans = "" CALL ErrorMsg(msg="No Case Found For Type of obj2", & - routine="BaseInterpolation_ToString1()", & + routine="BaseInterpolation_ToString()", & line=__LINE__, unitno=stdout, file=__FILE__) STOP END SELECT -END FUNCTION BaseInterpolation_ToString1 +END FUNCTION BaseInterpolation_ToChar !---------------------------------------------------------------------------- ! BaseType_ToChar @@ -556,18 +557,18 @@ END FUNCTION BaseType_ToChar ! QuadraturePointIDToName !---------------------------------------------------------------------------- -FUNCTION BaseInterpolation_ToString2(name, isUpper) RESULT(ans) +FUNCTION InterpolationPoint_ToString(name, isUpper) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper TYPE(String) :: ans - ans = BaseInterpolation_ToChar(name=name, isUpper=isUpper) -END FUNCTION BaseInterpolation_ToString2 + ans = InterpolationPoint_ToChar(name=name, isUpper=isUpper) +END FUNCTION InterpolationPoint_ToString !---------------------------------------------------------------------------- ! BaseInterpolation_ToChar !---------------------------------------------------------------------------- -FUNCTION BaseInterpolation_ToChar(name, isUpper) RESULT(ans) +FUNCTION InterpolationPoint_ToChar(name, isUpper) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper CHARACTER(:), ALLOCATABLE :: ans @@ -734,7 +735,7 @@ FUNCTION BaseInterpolation_ToChar(name, isUpper) RESULT(ans) STOP END SELECT -END FUNCTION BaseInterpolation_ToChar +END FUNCTION InterpolationPoint_ToChar !---------------------------------------------------------------------------- ! diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index cf90c2a59..e4ca4a758 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -15,8 +15,6 @@ ! 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 @@ -24,9 +22,10 @@ USE ErrorHandling, ONLY: ErrorMsg -USE BaseInterpolation_Method, ONLY: BaseInterpolation_ToString, & - BaseInterpolation_ToInteger, & - BaseInterpolation_ToChar +USE BaseInterpolation_Method, ONLY: InterpolationPoint_ToChar, & + InterpolationPoint_ToInteger, & + InterpolationPoint_ToString + USE ReallocateUtility, ONLY: Reallocate USE ReferenceElement_Method, ONLY: ElementTopology, & @@ -57,7 +56,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePointIDToName -ans = BaseInterpolation_ToString(name) +ans = InterpolationPoint_ToString(name) END PROCEDURE QuadraturePointIDToName !---------------------------------------------------------------------------- @@ -65,7 +64,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_ToChar -ans = BaseInterpolation_ToChar(name) +ans = InterpolationPoint_ToChar(name) END PROCEDURE QuadraturePoint_ToChar !---------------------------------------------------------------------------- @@ -73,7 +72,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePointNameToID -ans = BaseInterpolation_ToInteger(name) +ans = InterpolationPoint_ToInteger(name) END PROCEDURE QuadraturePointNameToID !---------------------------------------------------------------------------- From 6ab844605cf2a8f56bc4b8558d66e1d966ab1f3b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 24 Jul 2025 07:45:15 +0900 Subject: [PATCH 008/184] minor formatting in parameterlist --- src/modules/FPL/src/ParameterList.F90 | 65 ++++++++++++++------------- 1 file changed, 33 insertions(+), 32 deletions(-) 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) From 90fa49c506fb4f35eb7dd6ab4fff03997ccf9860 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 25 Jul 2025 12:51:02 +0900 Subject: [PATCH 009/184] Minor updates in IntVector and BoundingBox --- src/modules/BaseType/src/BaseType.F90 | 10 +- .../BoundingBox/src/BoundingBox_Method.F90 | 43 ++- .../src/IntVector_ConstructorMethod.F90 | 157 ++++++---- .../BoundingBox_Method@ConstructorMethods.F90 | 23 ++ .../IntVector_ConstructorMethod@Methods.F90 | 296 +++++++++++------- .../IntVector/src/include/Initiate4.F90 | 8 + 6 files changed, 338 insertions(+), 199 deletions(-) create mode 100644 src/submodules/IntVector/src/include/Initiate4.F90 diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 61ddc1fa1..8473f2bfa 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -278,11 +278,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() @@ -300,10 +300,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() 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/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 index d96efafe3..2b66681e4 100644 --- a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 +++ b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 @@ -43,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 !---------------------------------------------------------------------------- @@ -58,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 !---------------------------------------------------------------------------- @@ -78,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 !---------------------------------------------------------------------------- @@ -93,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 !---------------------------------------------------------------------------- @@ -108,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 !---------------------------------------------------------------------------- @@ -123,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 !---------------------------------------------------------------------------- @@ -142,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 !---------------------------------------------------------------------------- @@ -157,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 !---------------------------------------------------------------------------- @@ -173,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 !---------------------------------------------------------------------------- @@ -195,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(=) !---------------------------------------------------------------------------- @@ -237,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 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 intVec_initiate5a, intVec_initiate5b + MODULE PROCEDURE obj_initiate6 END INTERFACE ASSIGNMENT(=) +INTERFACE COPY + MODULE PROCEDURE obj_initiate6 +END INTERFACE COPY + !---------------------------------------------------------------------------- ! IntVector@Constructor !---------------------------------------------------------------------------- @@ -262,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 !---------------------------------------------------------------------------- @@ -278,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 !---------------------------------------------------------------------------- @@ -297,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 !---------------------------------------------------------------------------- @@ -313,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 !---------------------------------------------------------------------------- @@ -329,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 !---------------------------------------------------------------------------- @@ -345,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 !---------------------------------------------------------------------------- @@ -356,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(=) !---------------------------------------------------------------------------- @@ -368,7 +391,7 @@ 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 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/IntVector/src/IntVector_ConstructorMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 index cefd52e88..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,268 @@ ! !---------------------------------------------------------------------------- -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 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate4b -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4b +MODULE PROCEDURE obj_initiate4b +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4b -MODULE PROCEDURE intVec_initiate4c -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4c +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate4d -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4d +MODULE PROCEDURE obj_initiate4c +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4c !---------------------------------------------------------------------------- -! Initiate +! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate5a -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate5a +MODULE PROCEDURE obj_initiate4d +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4d -MODULE PROCEDURE intVec_initiate5b -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate5b +!---------------------------------------------------------------------------- +! 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 + +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 + +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 !---------------------------------------------------------------------------- @@ -247,12 +301,13 @@ MODULE PROCEDURE obj_Copy_Int8 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO - END PROCEDURE obj_Copy_Int8 !---------------------------------------------------------------------------- @@ -261,9 +316,11 @@ MODULE PROCEDURE obj_Copy_Int16 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO END PROCEDURE obj_Copy_Int16 @@ -274,9 +331,11 @@ MODULE PROCEDURE obj_Copy_Int32 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO END PROCEDURE obj_Copy_Int32 @@ -287,9 +346,11 @@ MODULE PROCEDURE obj_Copy_Int64 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO END PROCEDURE obj_Copy_Int64 @@ -299,11 +360,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Copy1_ -INTEGER(I4B) :: xx, yy +INTEGER(I4B) :: yy -DO yy = y_start, y_end - xx = x_start + yy - y_start - x(xx) = y(yy) +DO CONCURRENT(yy=y_start:y_end) + x(x_start + yy - y_start) = y(yy) END DO END PROCEDURE obj_Copy1_ 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) From 9212450ab5a7bba9b43173f67868ae7e2b78c13f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 26 Aug 2025 10:34:18 +0900 Subject: [PATCH 010/184] Minor update in BaseType --- src/modules/BaseType/src/BaseType.F90 | 75 ++++++++++++++++++++++++--- 1 file changed, 67 insertions(+), 8 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 8473f2bfa..957e6b552 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -20,12 +20,72 @@ ! [[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, 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 @@ -529,8 +589,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() @@ -1094,10 +1154,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_ @@ -1477,7 +1535,7 @@ END SUBROUTINE highorder_refelem REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) !! Local derivative of a shape function !! shape = nns, xidim, nips - !! dim 1 = number of nodes in element + !! dim 1 = number of nodes in element !! dim 2 = xi dimension (xi, eta, zeta) !! dim 3 = number of integration points REAL(DFP), ALLOCATABLE :: jacobian(:, :, :) @@ -1948,6 +2006,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: spacetime = spacetime INTEGER(I4B) :: solutionDependent = solutionDependent INTEGER(I4B) :: randomSpace = randomSpace + INTEGER(I4B) :: maxRank = MAX_RANK_FEVARIABLE END TYPE FEVariableOpt_ TYPE(FEVariableOpt_), PARAMETER :: TypeFEVariableOpt = FEVariableOpt_() From 9f0956244573aa31bf129b615d63cc6a21fa4321 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 26 Aug 2025 10:34:36 +0900 Subject: [PATCH 011/184] Minor Formatting --- src/modules/FACE/src/face.F90 | 18 +- src/modules/FPL/src/FPL_utils.F90 | 22 +- .../DimensionsWrapper0D_I4P.F90 | 371 +++++------ .../DimensionsWrapper0D_I8P.F90 | 372 +++++------ .../DimensionsWrapper0D_L.F90 | 372 +++++------ .../DimensionsWrapper0D_R4P.F90 | 373 +++++------ .../DimensionsWrapper0D_R8P.F90 | 374 +++++------ .../DimensionsWrapper1D_I4P.F90 | 389 ++++++----- .../DimensionsWrapper1D_L.F90 | 408 ++++++------ .../DimensionsWrapper1D_R4P.F90 | 389 ++++++----- .../DimensionsWrapper1D_R8P.F90 | 390 ++++++----- .../DimensionsWrapper2D_I4P.F90 | 419 ++++++------ .../DimensionsWrapper2D_I8P.F90 | 417 ++++++------ .../DimensionsWrapper2D_L.F90 | 424 ++++++------ .../DimensionsWrapper2D_R4P.F90 | 419 ++++++------ .../DimensionsWrapper2D_R8P.F90 | 420 ++++++------ .../DimensionsWrapper3D_I4P.F90 | 425 ++++++------ .../DimensionsWrapper3D_I8P.F90 | 425 ++++++------ .../DimensionsWrapper3D_L.F90 | 432 ++++++------ .../DimensionsWrapper3D_R4P.F90 | 430 ++++++------ .../DimensionsWrapper3D_R8P.F90 | 428 ++++++------ .../DimensionsWrapper4D_I4P.F90 | 433 ++++++------ .../DimensionsWrapper4D_I8P.F90 | 434 ++++++------ .../DimensionsWrapper4D_L.F90 | 438 ++++++------ .../DimensionsWrapper4D_R4P.F90 | 436 ++++++------ .../DimensionsWrapper4D_R8P.F90 | 436 ++++++------ .../DimensionsWrapper5D_I2P.F90 | 445 ++++++------- .../DimensionsWrapper5D_I4P.F90 | 443 ++++++------ .../DimensionsWrapper5D_I8P.F90 | 444 ++++++------- .../DimensionsWrapper5D_L.F90 | 450 ++++++------- .../DimensionsWrapper5D_R4P.F90 | 447 ++++++------- .../DimensionsWrapper5D_R8P.F90 | 448 ++++++------- .../DimensionsWrapper6D_I2P.F90 | 453 ++++++------- .../DimensionsWrapper6D_I4P.F90 | 453 ++++++------- .../DimensionsWrapper6D_I8P.F90 | 454 ++++++------- .../DimensionsWrapper6D_L.F90 | 456 +++++++------ .../DimensionsWrapper6D_R4P.F90 | 456 +++++++------ .../DimensionsWrapper6D_R8P.F90 | 456 +++++++------ .../DimensionsWrapper7D.F90 | 70 +- .../DimensionsWrapper7D_I2P.F90 | 457 +++++++------ .../DimensionsWrapper7D_I4P.F90 | 457 +++++++------ .../DimensionsWrapper7D_I8P.F90 | 459 +++++++------ .../DimensionsWrapper7D_L.F90 | 460 +++++++------ .../DimensionsWrapper7D_R4P.F90 | 459 +++++++------ .../DimensionsWrapper7D_R8P.F90 | 458 +++++++------ .../WrapperFactory/I2PWrapperFactory.F90 | 628 +++++++++--------- .../WrapperFactory/I4PWrapperFactory.F90 | 628 +++++++++--------- .../WrapperFactory/R4PWrapperFactory.F90 | 628 +++++++++--------- .../WrapperFactory/R8PWrapperFactory.F90 | 628 +++++++++--------- .../Wrapper/WrapperFactoryListSingleton.F90 | 32 +- src/modules/GlobalData/src/GlobalData.F90 | 4 +- src/modules/String/src/String_Class.F90 | 2 +- 52 files changed, 10085 insertions(+), 10584 deletions(-) diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90 index 09242bda0..0ce5c35fb 100644 --- a/src/modules/FACE/src/face.F90 +++ b/src/modules/FACE/src/face.F90 @@ -21,7 +21,7 @@ MODULE face #ifdef UCS4_SUPPORTED MODULE PROCEDURE colorize_ucs4 #endif -end interface +END INTERFACE ! kind parameters #ifdef ASCII_SUPPORTED @@ -119,7 +119,7 @@ SUBROUTINE colors_samples() 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') END DO -end subroutine colors_samples +END SUBROUTINE colors_samples SUBROUTINE styles_samples() !< Print to standard output all styles samples. @@ -131,7 +131,7 @@ SUBROUTINE styles_samples() colorize(STYLES(1, s), style=STYLES(1, s))// & ' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on') END DO -end subroutine styles_samples +END SUBROUTINE styles_samples ! private procedures pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized) @@ -172,7 +172,7 @@ pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized colorized = colorized//buffer END IF END IF -end function colorize_ascii +END FUNCTION colorize_ascii pure function colorize_default(string, color_fg, color_bg, style) result(colorized) !< Colorize and stylize strings, DEFAULT kind. @@ -196,7 +196,7 @@ pure function colorize_default(string, color_fg, color_bg, style) result(coloriz i = style_index(upper(style)) if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR END IF -end function colorize_default +END FUNCTION colorize_default pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) !< Colorize and stylize strings, UCS4 kind. @@ -236,7 +236,7 @@ pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) colorized = colorized//buffer END IF END IF -end function colorize_ucs4 +END FUNCTION colorize_ucs4 ELEMENTAL FUNCTION color_index(color) !< Return the array-index corresponding to the queried color. @@ -254,7 +254,7 @@ ELEMENTAL FUNCTION color_index(color) EXIT END IF END DO -end function color_index +END FUNCTION color_index ELEMENTAL FUNCTION style_index(style) !< Return the array-index corresponding to the queried style. @@ -269,7 +269,7 @@ ELEMENTAL FUNCTION style_index(style) EXIT END IF END DO -end function style_index +END FUNCTION style_index ELEMENTAL FUNCTION upper(string) !< Return a string with all uppercase characters. @@ -283,5 +283,5 @@ ELEMENTAL FUNCTION upper(string) n2 = INDEX(LOWER_ALPHABET, string(n1:n1)) IF (n2 > 0) upper(n1:n1) = UPPER_ALPHABET(n2:n2) END DO -end function upper +END FUNCTION upper endmodule face 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/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/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 index 2adf09ce3..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 diff --git a/src/modules/String/src/String_Class.F90 b/src/modules/String/src/String_Class.F90 index 49f90a65c..cc89858e7 100644 --- a/src/modules/String/src/String_Class.F90 +++ b/src/modules/String/src/String_Class.F90 @@ -3178,7 +3178,7 @@ ELEMENTAL FUNCTION to_logical_1(self, kind) RESULT(ans) !! Mold parameter for kind detection. LOGICAL :: ans !! The number into the string. - + ans = self%to_logical() END FUNCTION to_logical_1 From d94e883531dcabfafa13c84628756a1ea8970d8a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 27 Aug 2025 10:45:28 +0900 Subject: [PATCH 012/184] minor updates in DOF_GetMethods --- .../DOF/src/DOF_GetMethods@Methods.F90 | 106 ++++++++++++------ 1 file changed, 73 insertions(+), 33 deletions(-) diff --git a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 index 1c00e54ca..5b0844851 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,7 +676,6 @@ END DO tsize = tsize - 1 - END PROCEDURE obj_GetNodeLoc_13 !---------------------------------------------------------------------------- From 0c0e60e682c65e9294932ac8e54c6a1c7253f81d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 29 Aug 2025 07:21:22 +0900 Subject: [PATCH 013/184] Name change in ForceVector --- .../ForceVector/src/ForceVector_Method.F90 | 85 +++++++++--------- .../src/ForceVector_Method@Methods.F90 | 90 ++++++++++--------- 2 files changed, 89 insertions(+), 86 deletions(-) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 3e4deb1af..c9996e544 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -16,8 +16,9 @@ ! MODULE ForceVector_Method -USE BaseType -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_, FEVariable_, FEVariableScalar_, & + FEVariableVector_, FEVariableMatrix_ IMPLICIT NONE PRIVATE @@ -40,10 +41,10 @@ MODULE ForceVector_Method ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_1(test) RESULT(ans) + MODULE PURE FUNCTION ForceVector1(test) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_1 + END FUNCTION ForceVector1 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -61,35 +62,12 @@ END FUNCTION ForceVector_1 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_2b(test, c) RESULT(ans) - CLASS(ElemshapeData_), INTENT(IN) :: test - REAL(DFP), INTENT(IN) :: c(:) - !! defined on quadrature point - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_2b -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 ForceVector - MODULE PURE FUNCTION ForceVector_2(test, c, crank) RESULT(ans) + MODULE PURE FUNCTION ForceVector2(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableScalar_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_2 + END FUNCTION ForceVector2 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -109,12 +87,12 @@ END FUNCTION ForceVector_2 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_3(test, c, crank) RESULT(ans) + MODULE PURE 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 ForceVector !---------------------------------------------------------------------------- @@ -134,12 +112,12 @@ END FUNCTION ForceVector_3 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_4(test, c, crank) RESULT(ans) + MODULE PURE 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 ForceVector !---------------------------------------------------------------------------- @@ -159,15 +137,15 @@ END FUNCTION ForceVector_4 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_5(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) + MODULE PURE 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 ForceVector !---------------------------------------------------------------------------- @@ -187,15 +165,15 @@ END FUNCTION ForceVector_5 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_6(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) + MODULE PURE 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 ForceVector !---------------------------------------------------------------------------- @@ -215,15 +193,38 @@ END FUNCTION ForceVector_6 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_7(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) + MODULE PURE 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 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 ForceVector + MODULE PURE 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 ForceVector END MODULE ForceVector_Method diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index c090b621c..1da09a0be 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -16,7 +16,9 @@ ! SUBMODULE(ForceVector_Method) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate +USE ElemshapeData_Method, ONLY: GetInterpolation +use ProductUtility, only: OuterProd IMPLICIT NONE CONTAINS @@ -24,27 +26,26 @@ ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_1 +MODULE PROCEDURE ForceVector1 ! 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)) +CALL Reallocate(ans, test%nns) -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:test%nns) = ans(1:test%nns) + realval * test%N(1:test%nns, ips) END DO -DEALLOCATE (realval) -END PROCEDURE ForceVector_1 +END PROCEDURE ForceVector1 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_2 +MODULE PROCEDURE ForceVector2 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) INTEGER(I4B) :: ips @@ -54,37 +55,18 @@ realval = test%js * test%ws * test%thickness * realval CALL Reallocate(ans, SIZE(test%N, 1)) -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) -END DO -DEALLOCATE (realval) -END PROCEDURE ForceVector_2 - -!---------------------------------------------------------------------------- -! ForceVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ForceVector_2b -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips - -realval = test%js * test%ws * test%thickness * c -CALL Reallocate(ans, SIZE(test%N, 1)) - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) +DO ips = 1, test%nips + ans = ans + realval(ips) * test%N(1:test%nns, ips) END DO DEALLOCATE (realval) - -END PROCEDURE ForceVector_2b +END PROCEDURE ForceVector2 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_3 +MODULE PROCEDURE ForceVector3 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: cbar(:, :) @@ -96,17 +78,17 @@ CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(cbar(:, ips), test%N(:, ips)) + ans = ans + realval(ips) * OuterProd(cbar(:, ips), test%N(:, ips)) END DO DEALLOCATE (realval, cbar) -END PROCEDURE ForceVector_3 +END PROCEDURE ForceVector3 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_4 +MODULE PROCEDURE ForceVector4 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: cbar(:, :, :) @@ -118,17 +100,17 @@ CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), SIZE(test%N, 1)) DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(cbar(:, :, ips), test%N(:, ips)) + ans = ans + realval(ips) * OuterProd(cbar(:, :, ips), test%N(:, ips)) END DO DEALLOCATE (realval, cbar) -END PROCEDURE ForceVector_4 +END PROCEDURE ForceVector4 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_5 +MODULE PROCEDURE ForceVector5 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: c1bar(:) @@ -146,13 +128,13 @@ END DO DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_5 +END PROCEDURE ForceVector5 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_6 +MODULE PROCEDURE ForceVector6 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: c1bar(:) @@ -170,13 +152,13 @@ END DO DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_6 +END PROCEDURE ForceVector6 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_7 +MODULE PROCEDURE ForceVector7 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: c1bar(:) @@ -194,7 +176,27 @@ END DO DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_7 +END PROCEDURE ForceVector7 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector8 +! Define internal variable +REAL(DFP), ALLOCATABLE :: realval(:) +INTEGER(I4B) :: ips + +realval = test%js * test%ws * test%thickness * c +CALL Reallocate(ans, SIZE(test%N, 1)) + +DO ips = 1, SIZE(realval) + ans = ans + realval(ips) * test%N(:, ips) +END DO + +DEALLOCATE (realval) + +END PROCEDURE ForceVector8 !---------------------------------------------------------------------------- ! From c8c3b087295718ac7ff40655846341e6e6ac27ed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 29 Aug 2025 07:21:32 +0900 Subject: [PATCH 014/184] Minor formatting in ElemshapeData --- .../src/ElemshapeData_InterpolMethods@Methods.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index 321a86582..d69f7b604 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -96,8 +96,8 @@ interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) CASE (Space) IF (val%DefineOn .EQ. Nodal) THEN - interpol = interpolation(obj, & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) + interpol = Interpolation(obj, & + Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) ELSE interpol = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) END IF @@ -106,7 +106,7 @@ TYPE IS (STElemShapeData_) IF (val%DefineOn .EQ. Nodal) THEN interpol = STinterpolation(obj, & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) + Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) END IF END SELECT END SELECT From 79de13681b5d075d0d5f9dfeb5c3ced4b1176030 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 29 Aug 2025 11:44:30 +0900 Subject: [PATCH 015/184] Minor updates in FEVariable_Method --- .../src/FEVariable_Method@GetMethods.F90 | 191 ++++++------------ 1 file changed, 65 insertions(+), 126 deletions(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 index c7371d23e..9c64bb173 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 @@ -206,7 +206,6 @@ PURE SUBROUTINE Master_Get_vec_(obj, val, tsize) tsize = obj%len val(1:tsize) = obj%val(1:tsize) - END SUBROUTINE Master_Get_vec_ !---------------------------------------------------------------------------- @@ -258,13 +257,44 @@ PURE SUBROUTINE Master_get_mat3_(obj, val, dim1, dim2, dim3) 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)) -val = obj%val(1:obj%len) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Space !---------------------------------------------------------------------------- @@ -272,7 +302,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Space_ -CALL Master_Get_vec_(obj, val, tsize) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Space_ !---------------------------------------------------------------------------- @@ -280,8 +310,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Time +INTEGER(I4B) :: tsize ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Time !---------------------------------------------------------------------------- @@ -289,7 +320,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Time_ -CALL Master_Get_vec_(obj, val, tsize) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Time_ !---------------------------------------------------------------------------- @@ -297,19 +328,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_SpaceTime -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - - END DO -END DO - +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Scalar_SpaceTime !---------------------------------------------------------------------------- @@ -317,7 +338,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_SpaceTime_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Scalar_SpaceTime_ !---------------------------------------------------------------------------- @@ -325,8 +346,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Constant +INTEGER(I4B) :: tsize ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Vector_Constant !---------------------------------------------------------------------------- @@ -334,7 +356,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Constant_ -CALL Master_Get_vec_(obj, val, tsize) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Vector_Constant_ !---------------------------------------------------------------------------- @@ -342,18 +364,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Space -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO - +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Space !---------------------------------------------------------------------------- @@ -361,7 +374,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Space_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Space_ !---------------------------------------------------------------------------- @@ -369,17 +382,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Time -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Time !---------------------------------------------------------------------------- @@ -387,7 +392,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Time_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Time_ !---------------------------------------------------------------------------- @@ -395,19 +400,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_SpaceTime -INTEGER(I4B) :: ii, jj, kk, cnt - +INTEGER(I4B) :: dim1, dim2, dim3 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Vector_SpaceTime !---------------------------------------------------------------------------- @@ -415,7 +410,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_SpaceTime_ -CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Vector_SpaceTime_ !---------------------------------------------------------------------------- @@ -423,17 +418,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Constant -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Matrix_Constant !---------------------------------------------------------------------------- @@ -441,7 +428,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Constant_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Matrix_Constant_ !---------------------------------------------------------------------------- @@ -449,19 +436,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Space -INTEGER(I4B) :: ii, jj, kk, cnt - +INTEGER(I4B) :: dim1, dim2, dim3 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Space !---------------------------------------------------------------------------- @@ -469,7 +446,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Space_ -CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Space_ !---------------------------------------------------------------------------- @@ -477,19 +454,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Time -INTEGER(I4B) :: ii, jj, kk, cnt - +INTEGER(I4B) :: dim1, dim2, dim3 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Time !---------------------------------------------------------------------------- @@ -497,7 +464,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Time_ -CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Time_ !---------------------------------------------------------------------------- @@ -505,21 +472,10 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_SpaceTime -INTEGER(I4B) :: ii, jj, kk, ll, cnt - +INTEGER(I4B) :: dim1, dim2, dim3, dim4 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4))) - -cnt = 0 -DO ll = 1, obj%s(4) - DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk, ll) = obj%val(cnt) - END DO - END DO - END DO -END DO +CALL Master_get_mat4_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) END PROCEDURE Matrix_SpaceTime !---------------------------------------------------------------------------- @@ -527,25 +483,8 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_SpaceTime_ -INTEGER(I4B) :: ii, jj, kk, ll, cnt - -dim1 = obj%s(1) -dim2 = obj%s(2) -dim3 = obj%s(3) -dim4 = obj%s(4) - -cnt = 0 -DO ll = 1, dim4 - DO kk = 1, dim3 - DO jj = 1, dim2 - DO ii = 1, dim1 - cnt = cnt + 1 - val(ii, jj, kk, ll) = obj%val(cnt) - END DO - END DO - END DO -END DO - +CALL Master_get_mat4_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) END PROCEDURE Matrix_SpaceTime_ !---------------------------------------------------------------------------- From d1163936b382516e260d72365e3caad693895b9f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 30 Aug 2025 13:10:45 +0900 Subject: [PATCH 016/184] Updates in ElemShapeData and FEVariable --- src/modules/ElemshapeData/CMakeLists.txt | 3 + .../src/ElemshapeData_InterpolMethods.F90 | 767 +------------- .../ElemshapeData_MatrixInterpolMethods.F90 | 247 +++++ .../src/ElemshapeData_Method.F90 | 5 + .../ElemshapeData_ScalarInterpolMethods.F90 | 426 ++++++++ .../ElemshapeData_VectorInterpolMethods.F90 | 302 ++++++ .../FEVariable/src/FEVariable_Method.F90 | 121 ++- src/submodules/ElemshapeData/CMakeLists.txt | 3 + .../ElemshapeData_InterpolMethods@Methods.F90 | 985 ++---------------- ...hapeData_MatrixInterpolMethods@Methods.F90 | 301 ++++++ ...hapeData_ScalarInterpolMethods@Methods.F90 | 286 +++++ .../src/ElemshapeData_SetMethods@Methods.F90 | 38 +- ...hapeData_VectorInterpolMethods@Methods.F90 | 317 ++++++ src/submodules/FEVariable/CMakeLists.txt | 60 +- ...able_Method@ScalarInterpolationMethods.F90 | 130 +++ 15 files changed, 2256 insertions(+), 1735 deletions(-) create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 create mode 100644 src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 create mode 100644 src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt index 1ce516e03..85dc0942c 100644 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -34,6 +34,9 @@ target_sources( ${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 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index f6ab5ef77..66c173b8f 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -18,638 +18,13 @@ ! This file contains the interpolation methods interfaces\ MODULE ElemshapeData_InterpolMethods -USE BaseType -USE GlobalData +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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation1_(obj, interpol, val, tsize) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) - REAL(DFP), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE scalar_getInterpolation1_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation2_(obj, interpol, val, tsize) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) - REAL(DFP), INTENT(IN) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE scalar_getInterpolation2_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation3_(obj, interpol, val, & - nrow, ncol) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - REAL(DFP), INTENT(IN) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE scalar_getInterpolation3_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 scalar_getInterpolation_4(obj, interpol, 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation4_(obj, interpol, val, tsize) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE scalar_getInterpolation4_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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(IN) :: val - !! scalar FE variable - END SUBROUTINE scalar_getInterpolation_5 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation5_(obj, interpol, val, & - nrow, ncol) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE scalar_getInterpolation5_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation1_(obj, interpol, val, & - nrow, ncol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - REAL(DFP), INTENT(IN) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE vector_getInterpolation1_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, interpol, val, & - nrow, ncol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - REAL(DFP), INTENT(IN) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE vector_getInterpolation2_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation3_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE vector_getInterpolation3_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 vector_getInterpolation_4(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) - !! interpolation of vector - TYPE(FEVariable_), INTENT(IN) :: val - !! vector FEvariable - END SUBROUTINE vector_getInterpolation_4 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, interpol, val, & - nrow, ncol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE vector_getInterpolation4_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 vector_getInterpolation_5(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) - !! space-time interpolation of vector - TYPE(FEVariable_), INTENT(IN) :: val - !! vector FEvariable - END SUBROUTINE vector_getInterpolation_5 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation5_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE vector_getInterpolation5_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine performs interpolation of matrix - -INTERFACE GetInterpolation - 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE matrix_getInterpolation1_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE matrix_getInterpolation2_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> 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 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 GetInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine performs interpolation of matrix FEVariable -! -INTERFACE GetInterpolation - 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 GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE matrix_getInterpolation4_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :) - !! space-time interpolation of matrix - TYPE(FEVariable_), INTENT(IN) :: val - !! matrix fe variable - END SUBROUTINE matrix_getInterpolation_5 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, interpol, val, & - dim1, dim2, dim3, dim4) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :, :) - TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 - END SUBROUTINE matrix_getInterpolation5_ -END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- ! getInterpolation@InterpolMethods @@ -707,62 +82,6 @@ MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val) END SUBROUTINE master_getInterpolation_2 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 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 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 !---------------------------------------------------------------------------- @@ -784,86 +103,4 @@ END FUNCTION master_interpolation_1 MODULE PROCEDURE master_interpolation_1 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 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 new file mode 100644 index 000000000..52b7110e2 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 @@ -0,0 +1,247 @@ +! 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@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of matrix + +INTERFACE GetInterpolation + 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 GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matrix_getInterpolation1_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 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 GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matrix_getInterpolation2_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 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 GetInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of matrix FEVariable +! +INTERFACE GetInterpolation + 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 GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matrix_getInterpolation4_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :) + !! space-time interpolation of matrix + TYPE(FEVariable_), INTENT(IN) :: val + !! matrix fe variable + END SUBROUTINE matrix_getInterpolation_5 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, interpol, val, & + dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE matrix_getInterpolation5_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! STInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 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_MatrixInterpolMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 841d55eda..9d1e6e6c0 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -33,7 +33,12 @@ MODULE ElemshapeData_Method 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 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 new file mode 100644 index 000000000..941d8d078 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 @@ -0,0 +1,426 @@ +! 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, 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 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, interpol, val, tsize) + CLASS(ElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE 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, interpol, val, & + tsize, scale, & + addContribution) + CLASS(ElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + 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, interpol, val) + CLASS(STElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:) + !! 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, interpol, val, tsize) + CLASS(STElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + 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, interpol, val, & + tsize, scale, & + addContribution) + CLASS(STElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + 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, 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 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, interpol, val, & + nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE 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, interpol, val, & + nrow, ncol, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + 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, interpol, 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 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, interpol, val, tsize) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE 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, interpol, val, tsize, & + scale, addContribution, timeIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:) + 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@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, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + !! 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, interpol, val, & + nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE 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, interpol, val, & + nrow, ncol, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + 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(interpol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), ALLOCATABLE :: interpol(:) + 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(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 STInterpolation1 +END INTERFACE + +INTERFACE STInterpolation + MODULE PROCEDURE STInterpolation1 +END INTERFACE STInterpolation + +END MODULE ElemshapeData_ScalarInterpolMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 new file mode 100644 index 000000000..63f29944d --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 @@ -0,0 +1,302 @@ +! 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@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 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 GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation1_(obj, interpol, val, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE vector_getInterpolation1_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 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 GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, interpol, val, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE vector_getInterpolation2_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 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 GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation3_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE vector_getInterpolation3_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 vector_getInterpolation_4(obj, interpol, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + !! interpolation of vector + TYPE(FEVariable_), INTENT(IN) :: val + !! vector FEvariable + END SUBROUTINE vector_getInterpolation_4 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, interpol, val, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: interpol(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE vector_getInterpolation4_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> 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 vector_getInterpolation_5(obj, interpol, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) + !! space-time interpolation of vector + TYPE(FEVariable_), INTENT(IN) :: val + !! vector FEvariable + END SUBROUTINE vector_getInterpolation_5 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE vector_getInterpolation5_(obj, interpol, val, & + dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE vector_getInterpolation5_ +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +END MODULE ElemshapeData_VectorInterpolMethods diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index acb6bd72b..fb2762199 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -22,7 +22,8 @@ MODULE FEVariable_Method FEVariableConstant_, & FEVariableSpace_, & FEVariableTime_, & - FEVariableSpaceTime_ + FEVariableSpaceTime_, & + TypeFEVariableOpt USE GlobalData, ONLY: I4B, DFP, LGT @@ -59,6 +60,7 @@ MODULE FEVariable_Method PUBLIC :: ASSIGNMENT(=) PUBLIC :: FEVariable_ToChar PUBLIC :: FEVariable_ToInteger +PUBLIC :: GetInterpolation_ INTEGER(I4B), PARAMETER :: CAPACITY_EXPAND_FACTOR = 1 ! capacity = tsize * CAPACITY_EXPAND_FACTOR @@ -1863,4 +1865,121 @@ MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans) END FUNCTION fevar_Mean4 END INTERFACE +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_(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_ +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_(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_ +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_(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_ +END INTERFACE GetInterpolation_ + END MODULE FEVariable_Method diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index bc0b5a57d..113ff1297 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -26,6 +26,9 @@ target_sources( ${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 diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index d69f7b604..144aa6ea9 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -16,859 +16,44 @@ ! SUBMODULE(ElemshapeData_InterpolMethods) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate IMPLICIT NONE CONTAINS -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE scalar_getinterpolation_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation1_ -tsize = SIZE(obj%N, 2) -interpol(1:tsize) = MATMUL(val, obj%N) -END PROCEDURE scalar_getinterpolation1_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation2_ -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - tsize = SIZE(obj%N, 2) - interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE scalar_getinterpolation2_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation3_ -INTEGER(I4B) :: ipt -nrow = SIZE(obj(1)%N, 2) -ncol = SIZE(obj) -DO ipt = 1, ncol - interpol(1:nrow, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) -END DO -END PROCEDURE scalar_getinterpolation3_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation4_ -SELECT CASE (val%vartype) -CASE (Constant) - tsize = SIZE(obj%N, 2) - interpol(1:tsize) = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, interpol=interpol, & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpace), & - tsize=tsize) - ELSE - CALL Get_(obj=val, rank=TypeFEVariableScalar, & - vartype=TypeFEVariableSpace, & - val=interpol, tsize=tsize) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, interpol=interpol, & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpaceTime), & - tsize=tsize) - END IF - END SELECT -END SELECT -END PROCEDURE scalar_getinterpolation4_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation5_ -INTEGER(I4B) :: ii -nrow = SIZE(obj(1)%N, 2) -ncol = SIZE(obj) -SELECT CASE (val%vartype) -CASE (Constant) - interpol(1:nrow, 1:ncol) = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, ncol - CALL GetInterpolation_(obj=obj(ii), & - interpol=interpol(1:nrow, ii), & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpace), & - tsize=nrow) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableScalar, & - vartype=TypeFEVariableSpace, & - val=interpol(1:nrow, 1), tsize=nrow) - DO ii = 2, ncol - interpol(1:nrow, ii) = interpol(1:nrow, 1) - END DO - END IF -CASE (SpaceTime) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, ncol - CALL GetInterpolation_(obj=obj(ii), & - interpol=interpol(1:nrow, ii), & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpaceTime), & - tsize=nrow) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableScalar, & - vartype=typeFEVariableSpaceTime, & - val=interpol, nrow=nrow, ncol=ncol) - END IF -END SELECT - -END PROCEDURE scalar_getinterpolation5_ - -!--------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation1_ -nrow = SIZE(val, 1) -ncol = SIZE(obj%N, 2) -interpol(1:nrow, 1:ncol) = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation1_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation2_ -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - nrow = SIZE(val, 1) - ncol = SIZE(obj%N, 2) - interpol(1:nrow, 1:ncol) = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE vector_getinterpolation2_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation3_ -INTEGER(I4B) :: ipt - -dim1 = SIZE(val, 1) -dim2 = SIZE(obj(1)%N, 2) -dim3 = SIZE(obj) -DO ipt = 1, dim3 - interpol(1:dim1, 1:dim2, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), & - obj(ipt)%N) -END DO -END PROCEDURE vector_getinterpolation3_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -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 vector_getinterpolation4_ -INTEGER(I4B) :: ii - -SELECT CASE (val%vartype) -CASE (Constant) - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableConstant, & - val=interpol(:, 1), tsize=nrow) - ncol = SIZE(obj%N, 2) - DO ii = 2, ncol - interpol(1:nrow, ii) = interpol(1:nrow, 1) - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpace), & - interpol=interpol, & - nrow=nrow, ncol=ncol) - ELSE - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableSpace, & - val=interpol, nrow=nrow, ncol=ncol) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpaceTime), & - interpol=interpol, & - nrow=nrow, ncol=ncol) - END SELECT -END SELECT - -END PROCEDURE vector_getinterpolation4_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation5_ -INTEGER(I4B) :: ii, jj - -dim1 = SIZE(val, 1) -dim2 = SIZE(obj(1)%N, 2) -dim3 = SIZE(obj) -SELECT CASE (val%vartype) -CASE (Constant) - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableConstant, & - val=interpol(:, 1, 1), tsize=dim1) - DO jj = 1, dim3 - DO ii = 1, dim2 - IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE - interpol(1:dim1, ii, jj) = interpol(1:dim1, 1, 1) - END DO - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, dim3 - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpace), & - interpol=interpol(1:dim1, 1:dim2, ii), & - nrow=dim1, ncol=dim2) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableSpace, & - val=interpol(:, :, 1), nrow=dim1, ncol=dim2) - DO ii = 2, SIZE(obj) - interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) - END DO - END IF -CASE (SpaceTime) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, SIZE(obj) - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpaceTime), & - interpol=interpol(1:dim1, 1:dim2, ii), & - nrow=dim1, ncol=dim2) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableSpaceTime, & - val=interpol, dim1=dim1, dim2=dim2, dim3=dim3) - END IF -END SELECT - -END PROCEDURE vector_getinterpolation5_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_getinterpolation_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation1_ -dim1 = SIZE(val, 1) -dim2 = SIZE(val, 2) -dim3 = SIZE(obj%N, 2) -interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(val, obj%N) -END PROCEDURE matrix_getinterpolation1_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_2 -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE matrix_getinterpolation_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation2_ -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - dim1 = SIZE(val, 1) - dim2 = SIZE(val, 2) - dim3 = SIZE(obj%N, 2) - interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE matrix_getinterpolation2_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_3 -!! TODO -END PROCEDURE matrix_getinterpolation_3 - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation4_ -INTEGER(I4B) :: ii - -SELECT CASE (val%vartype) -CASE (Constant) - dim3 = SIZE(obj%N, 2) - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableConstant, & - val=interpol(:, :, 1), nrow=dim1, ncol=dim2) - DO ii = 2, dim3 - interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpace), & - interpol=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3) - ELSE - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableSpace, val=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime), & - interpol=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3) - END IF - END SELECT -END SELECT -END PROCEDURE matrix_getinterpolation4_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation5_ -INTEGER(I4B) :: ii, jj -dim1 = SIZE(val, 1) -dim2 = SIZE(val, 2) -dim3 = SIZE(obj(1)%N, 2) -dim4 = SIZE(obj) - -SELECT CASE (val%vartype) -CASE (Constant) - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableConstant, val=interpol(:, :, 1, 1), & - nrow=dim1, ncol=dim2) - DO jj = 1, dim3 - DO ii = 1, dim4 - IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE - interpol(1:dim1, 1:dim2, ii, jj) = interpol(1:dim1, 1:dim2, 1, 1) - END DO - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, dim4 - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpace), & - interpol=interpol(:, :, :, ii), & - dim1=dim1, dim2=dim2, dim3=dim3) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableSpace, val=interpol(:, :, :, 1), & - dim1=dim1, dim2=dim2, dim3=dim3) - DO ii = 2, dim4 - interpol(1:dim1, 1:dim2, 1:dim3, ii) = & - interpol(1:dim1, 1:dim2, 1:dim3, 1) - END DO - END IF -CASE (SpaceTime) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, dim4 - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime), & - interpol=interpol(:, :, :, ii), & - dim1=dim1, dim2=dim2, dim3=dim3) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableSpaceTime, val=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) - END IF -END SELECT -END PROCEDURE matrix_getinterpolation5_ - !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- 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 - +! 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 END PROCEDURE master_getinterpolation_1 !---------------------------------------------------------------------------- @@ -876,92 +61,44 @@ !---------------------------------------------------------------------------- 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 -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 -!! +! 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 +! 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 -!---------------------------------------------------------------------------- -! interpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_interpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE scalar_interpolation_1 - -!---------------------------------------------------------------------------- -! interpolationOfVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_interpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE vector_interpolation_1 - -!---------------------------------------------------------------------------- -! interpolationOfVector -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_interpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_interpolation_1 - !---------------------------------------------------------------------------- ! interpolationOfVector !---------------------------------------------------------------------------- MODULE PROCEDURE master_interpolation_1 -CALL getInterpolation(obj=obj, val=val, interpol=ans) +! 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 - -!---------------------------------------------------------------------------- -! STinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_stinterpolation_1 -interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END PROCEDURE matrix_stinterpolation_1 - END SUBMODULE Methods 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..6477e5d36 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 @@ -0,0 +1,301 @@ +! 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 +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation_1 +! interpol = MATMUL(val, obj%N) +END PROCEDURE matrix_getinterpolation_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation1_ +! dim1 = SIZE(val, 1) +! dim2 = SIZE(val, 2) +! dim3 = SIZE(obj%N, 2) +! interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(val, obj%N) +END PROCEDURE matrix_getinterpolation1_ + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation_2 +! SELECT TYPE (obj) +! TYPE IS (STElemShapeData_) +! interpol = MATMUL(MATMUL(val, obj%T), obj%N) +! END SELECT +END PROCEDURE matrix_getinterpolation_2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation2_ +! SELECT TYPE (obj) +! TYPE IS (STElemShapeData_) +! dim1 = SIZE(val, 1) +! dim2 = SIZE(val, 2) +! dim3 = SIZE(obj%N, 2) +! interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(MATMUL(val, obj%T), obj%N) +! END SELECT +END PROCEDURE matrix_getinterpolation2_ + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation_3 +!! TODO +END PROCEDURE matrix_getinterpolation_3 + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation4_ +! INTEGER(I4B) :: ii +! +! SELECT CASE (val%vartype) +! CASE (Constant) +! dim3 = SIZE(obj%N, 2) +! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & +! vartype=TypeFEVariableConstant, & +! val=interpol(:, :, 1), nrow=dim1, ncol=dim2) +! DO ii = 2, dim3 +! interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) +! END DO +! CASE (Space) +! IF (val%DefineOn .EQ. Nodal) THEN +! CALL GetInterpolation_(obj=obj, & +! val=Get(val, TypeFEVariableMatrix, & +! TypeFEVariableSpace), & +! interpol=interpol, & +! dim1=dim1, dim2=dim2, dim3=dim3) +! ELSE +! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & +! vartype=TypeFEVariableSpace, val=interpol, & +! dim1=dim1, dim2=dim2, dim3=dim3) +! END IF +! CASE (SpaceTime) +! SELECT TYPE (obj) +! TYPE IS (STElemShapeData_) +! IF (val%DefineOn .EQ. Nodal) THEN +! CALL GetInterpolation_(obj=obj, & +! val=Get(val, TypeFEVariableMatrix, & +! TypeFEVariableSpaceTime), & +! interpol=interpol, & +! dim1=dim1, dim2=dim2, dim3=dim3) +! END IF +! END SELECT +! END SELECT +END PROCEDURE matrix_getinterpolation4_ + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation_5 +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_getinterpolation5_ +! INTEGER(I4B) :: ii, jj +! dim1 = SIZE(val, 1) +! dim2 = SIZE(val, 2) +! dim3 = SIZE(obj(1)%N, 2) +! dim4 = SIZE(obj) +! +! SELECT CASE (val%vartype) +! CASE (Constant) +! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & +! vartype=TypeFEVariableConstant, val=interpol(:, :, 1, 1), & +! nrow=dim1, ncol=dim2) +! DO jj = 1, dim3 +! DO ii = 1, dim4 +! IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE +! interpol(1:dim1, 1:dim2, ii, jj) = interpol(1:dim1, 1:dim2, 1, 1) +! END DO +! END DO +! CASE (Space) +! IF (val%DefineOn .EQ. Nodal) THEN +! DO ii = 1, dim4 +! CALL GetInterpolation_(obj=obj(ii), & +! val=Get(val, TypeFEVariableMatrix, & +! TypeFEVariableSpace), & +! interpol=interpol(:, :, :, ii), & +! dim1=dim1, dim2=dim2, dim3=dim3) +! END DO +! ELSE +! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & +! vartype=TypeFEVariableSpace, val=interpol(:, :, :, 1), & +! dim1=dim1, dim2=dim2, dim3=dim3) +! DO ii = 2, dim4 +! interpol(1:dim1, 1:dim2, 1:dim3, ii) = & +! interpol(1:dim1, 1:dim2, 1:dim3, 1) +! END DO +! END IF +! CASE (SpaceTime) +! IF (val%DefineOn .EQ. Nodal) THEN +! DO ii = 1, dim4 +! CALL GetInterpolation_(obj=obj(ii), & +! val=Get(val, TypeFEVariableMatrix, & +! TypeFEVariableSpaceTime), & +! interpol=interpol(:, :, :, ii), & +! dim1=dim1, dim2=dim2, dim3=dim3) +! END DO +! ELSE +! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & +! vartype=TypeFEVariableSpaceTime, val=interpol, & +! dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) +! END IF +! END SELECT +END PROCEDURE matrix_getinterpolation5_ + +!---------------------------------------------------------------------------- +! interpolationOfVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_interpolation_1 +! interpol = MATMUL(val, obj%N) +END PROCEDURE matrix_interpolation_1 + +!---------------------------------------------------------------------------- +! STinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matrix_stinterpolation_1 +! interpol = MATMUL(MATMUL(val, obj%T), obj%N) +END PROCEDURE matrix_stinterpolation_1 + +END SUBMODULE Methods 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..1e46b5ce8 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 @@ -0,0 +1,286 @@ +! 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(interpol, obj%nips) +CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, & + tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) +END PROCEDURE GetInterpolation1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1 +CALL GetInterpolation_(obj=obj, interpol=interpol, 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) interpol(1:tsize) = 0.0_DFP + +! interpol(1:obj%nips) = MATMUL(val(1:minNNS), obj%N(1:minNNS, 1:obj%nips)) +DO ips = 1, obj%nips + DO ii = 1, minNNS + interpol(ips) = interpol(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(interpol, obj%nips) +CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, & + tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) +END PROCEDURE GetInterpolation2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2 +CALL GetInterpolation_(obj=obj, interpol=interpol, 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) interpol(1:obj%nips) = 0.0_DFP + +DO aa = 1, minNNT + myscale = obj%T(aa) * scale + CALL GetInterpolation_(obj=obj, interpol=interpol, 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(interpol, nrow, ncol) +CALL GetInterpolation_(obj=obj, interpol=interpol, & + val=val, nrow=nrow, ncol=ncol, scale=1.0_DFP, & + addContribution=.FALSE.) +END PROCEDURE GetInterpolation3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3 +CALL GetInterpolation_(obj=obj, interpol=interpol, & + 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), interpol=interpol(:, ipt), & + val=val, tsize=nrow, scale=scale, & + addContribution=addContribution) +END DO +END PROCEDURE GetInterpolation_3a + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation4 +INTEGER(I4B) :: tsize +CALL Reallocate(interpol, obj%nips) +CALL GetInterpolation_(obj=obj, interpol=interpol, 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, interpol=interpol, 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=interpol, 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=interpol, 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=interpol, tsize=tsize, & + timeIndx=timeIndx0) + + END SELECT + +END SELECT +END PROCEDURE GetInterpolation_4a + +!---------------------------------------------------------------------------- +! 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(interpol, nrow, ncol) +CALL GetInterpolation_(obj=obj, interpol=interpol, 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, interpol=interpol, 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), interpol=interpol(:, ipt), & + val=val, tsize=nrow, scale=scale, & + addContribution=addContribution, timeIndx=ipt) +END DO +END PROCEDURE GetInterpolation_5a + +!---------------------------------------------------------------------------- +! Interpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Interpolation1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: tsize +CALL Reallocate(interpol, obj%nips) +CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, tsize=tsize, & + scale=one, addContribution=no) +END PROCEDURE Interpolation1 + +!---------------------------------------------------------------------------- +! STInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STInterpolation1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: tsize +CALL Reallocate(interpol, obj%nips) +CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, tsize=tsize, & + scale=one, addContribution=no) +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 085d4e2ca..a8ad98d19 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -17,11 +17,8 @@ SUBMODULE(ElemshapeData_SetMethods) Methods USE ProductUtility, ONLY: VectorProduct, OuterProd - USE InvUtility, ONLY: Det, Inv - USE ReallocateUtility, ONLY: Reallocate - USE MatmulUtility IMPLICIT NONE @@ -49,9 +46,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetBarycentricCoord -INTEGER(I4B) :: nns -obj%coord(1:obj%nsd, 1:obj%nips) = MATMUL(val(1:obj%nsd, :), & - N(:, 1:obj%nips)) +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 !---------------------------------------------------------------------------- @@ -59,7 +58,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE stsd_SetBarycentricCoord -! TODO: Improve this function by removing the temporary variable +! 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 @@ -90,9 +89,12 @@ 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)) + 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 @@ -113,9 +115,7 @@ MODULE PROCEDURE elemsd_SetdNdXt ! Define internal variables INTEGER(I4B) :: ips - REAL(DFP) :: invJacobian(3, 3) - LOGICAL(LGT) :: abool abool = obj%nsd .NE. obj%xidim @@ -129,7 +129,7 @@ CALL Inv(InvA=invJacobian, A=obj%jacobian(1:obj%nsd, 1:obj%nsd, ips)) obj%dNdXt(1:obj%nns, 1:obj%nsd, ips) = & - MATMUL(obj%dNdXi(1:obj%nns, 1:obj%xidim, ips), & + MATMUL(obj%dNdXi(1:obj%nns, 1:obj%nsd, ips), & invJacobian(1:obj%nsd, 1:obj%nsd)) END DO @@ -140,8 +140,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetJacobian -obj%jacobian(1:obj%nsd, 1:obj%xidim, 1:obj%nips) = & - MATMUL(val(1:obj%nsd, :), dNdXi(:, 1:obj%xidim, 1:obj%nips)) +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 !---------------------------------------------------------------------------- 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..57fc49a9c --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 @@ -0,0 +1,317 @@ +! 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 +IMPLICIT NONE + +CONTAINS + +!--------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation_1 +interpol = MATMUL(val, obj%N) +END PROCEDURE vector_getinterpolation_1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation1_ +nrow = SIZE(val, 1) +ncol = SIZE(obj%N, 2) +interpol(1:nrow, 1:ncol) = MATMUL(val, obj%N) +END PROCEDURE vector_getinterpolation1_ + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation2_ +! SELECT TYPE (obj) +! TYPE IS (STElemShapeData_) +! nrow = SIZE(val, 1) +! ncol = SIZE(obj%N, 2) +! interpol(1:nrow, 1:ncol) = MATMUL(MATMUL(val, obj%T), obj%N) +! END SELECT +END PROCEDURE vector_getinterpolation2_ + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation3_ +! INTEGER(I4B) :: ipt +! +! dim1 = SIZE(val, 1) +! dim2 = SIZE(obj(1)%N, 2) +! dim3 = SIZE(obj) +! DO ipt = 1, dim3 +! interpol(1:dim1, 1:dim2, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), & +! obj(ipt)%N) +! END DO +END PROCEDURE vector_getinterpolation3_ + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +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 vector_getinterpolation4_ +! INTEGER(I4B) :: ii +! +! SELECT CASE (val%vartype) +! CASE (Constant) +! CALL Get_(obj=val, rank=TypeFEVariableVector, & +! vartype=TypeFEVariableConstant, & +! val=interpol(:, 1), tsize=nrow) +! ncol = SIZE(obj%N, 2) +! DO ii = 2, ncol +! interpol(1:nrow, ii) = interpol(1:nrow, 1) +! END DO +! CASE (Space) +! IF (val%DefineOn .EQ. Nodal) THEN +! CALL GetInterpolation_(obj=obj, & +! val=Get(val, TypeFEVariableVector, & +! TypeFEVariableSpace), & +! interpol=interpol, & +! nrow=nrow, ncol=ncol) +! ELSE +! CALL Get_(obj=val, rank=TypeFEVariableVector, & +! vartype=TypeFEVariableSpace, & +! val=interpol, nrow=nrow, ncol=ncol) +! END IF +! CASE (SpaceTime) +! SELECT TYPE (obj) +! TYPE IS (STElemShapeData_) +! CALL GetInterpolation_(obj=obj, & +! val=Get(val, TypeFEVariableVector, & +! TypeFEVariableSpaceTime), & +! interpol=interpol, & +! nrow=nrow, ncol=ncol) +! END SELECT +! END SELECT +END PROCEDURE vector_getinterpolation4_ + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation_5 +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_getinterpolation5_ +! INTEGER(I4B) :: ii, jj +! +! dim1 = SIZE(val, 1) +! dim2 = SIZE(obj(1)%N, 2) +! dim3 = SIZE(obj) +! SELECT CASE (val%vartype) +! CASE (Constant) +! CALL Get_(obj=val, rank=TypeFEVariableVector, & +! vartype=TypeFEVariableConstant, & +! val=interpol(:, 1, 1), tsize=dim1) +! DO jj = 1, dim3 +! DO ii = 1, dim2 +! IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE +! interpol(1:dim1, ii, jj) = interpol(1:dim1, 1, 1) +! END DO +! END DO +! CASE (Space) +! IF (val%DefineOn .EQ. Nodal) THEN +! DO ii = 1, dim3 +! CALL GetInterpolation_(obj=obj(ii), & +! val=Get(val, TypeFEVariableVector, & +! TypeFEVariableSpace), & +! interpol=interpol(1:dim1, 1:dim2, ii), & +! nrow=dim1, ncol=dim2) +! END DO +! ELSE +! CALL Get_(obj=val, rank=TypeFEVariableVector, & +! vartype=TypeFEVariableSpace, & +! val=interpol(:, :, 1), nrow=dim1, ncol=dim2) +! DO ii = 2, SIZE(obj) +! interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) +! END DO +! END IF +! CASE (SpaceTime) +! IF (val%DefineOn .EQ. Nodal) THEN +! DO ii = 1, SIZE(obj) +! CALL GetInterpolation_(obj=obj(ii), & +! val=Get(val, TypeFEVariableVector, & +! TypeFEVariableSpaceTime), & +! interpol=interpol(1:dim1, 1:dim2, ii), & +! nrow=dim1, ncol=dim2) +! END DO +! ELSE +! CALL Get_(obj=val, rank=TypeFEVariableVector, & +! vartype=TypeFEVariableSpaceTime, & +! val=interpol, dim1=dim1, dim2=dim2, dim3=dim3) +! END IF +! END SELECT +END PROCEDURE vector_getinterpolation5_ + +!---------------------------------------------------------------------------- +! interpolationOfVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE vector_interpolation_1 +! interpol = MATMUL(val, obj%N) +END PROCEDURE vector_interpolation_1 + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index ebcb11b22..988d1dc58 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -1,35 +1,35 @@ -# 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_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 + ${src_path}/FEVariable_Method@ScalarInterpolationMethods.F90) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 new file mode 100644 index 000000000..2b2d3e866 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 @@ -0,0 +1,130 @@ +! 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_Method) ScalarInterpolationMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarConstantGetInterpolation_ +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_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolation_(ans, scale, N, nns, nips, val, & + valStart) + 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 + + INTEGER(I4B) :: ips, ii + + DO ips = 1, nips + DO ii = 1, nns + ans(ips) = ans(ips) + scale * N(ii, ips) * val(valStart + ii) + END DO + END DO + +END SUBROUTINE MasterGetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarSpaceGetInterpolation_ +INTEGER(I4B) :: ips + +tsize = nips +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +SELECT CASE (obj%varType) +CASE (TypeFEVariableOpt%nodal) + !! convert nodal values to quadrature values by using N + !! make sure nns .LE. obj%len + + CALL MasterGetInterpolation_(ans=ans, scale=scale, N=N, nns=nns, & + nips=nips, val=obj%val, valStart=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_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_ +INTEGER(I4B) :: aa, valStart +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +tsize = nips +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +SELECT CASE (obj%varType) +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 MasterGetInterpolation_(ans=ans, scale=myscale, N=N, nns=nns, & + nips=nips, val=obj%val, valStart=valStart) + 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_ + +END SUBMODULE ScalarInterpolationMethods From 145a470e5458830659bda5b61727d7a844cc96ca Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 30 Aug 2025 15:23:14 +0900 Subject: [PATCH 017/184] Update in ElemShapeData Chaning interpol to ans. --- .../src/ElemshapeData_InterpolMethods.F90 | 10 +- .../ElemshapeData_MatrixInterpolMethods.F90 | 44 +++--- .../ElemshapeData_ScalarInterpolMethods.F90 | 68 +++++----- .../ElemshapeData_VectorInterpolMethods.F90 | 48 +++---- src/submodules/ConvectiveMatrix/src/CM_3.inc | 2 +- src/submodules/ConvectiveMatrix/src/CM_4.inc | 2 +- src/submodules/ConvectiveMatrix/src/CM_5.inc | 2 +- src/submodules/ConvectiveMatrix/src/CM_6.inc | 2 +- .../src/ConvectiveMatrix_Method@Methods.F90 | 8 +- src/submodules/DiffusionMatrix/src/DM_1.inc | 2 +- src/submodules/DiffusionMatrix/src/DM_10.inc | 4 +- src/submodules/DiffusionMatrix/src/DM_3.inc | 2 +- src/submodules/DiffusionMatrix/src/DM_5.inc | 4 +- src/submodules/DiffusionMatrix/src/DM_6.inc | 4 +- src/submodules/DiffusionMatrix/src/DM_7.inc | 2 +- src/submodules/DiffusionMatrix/src/DM_8.inc | 4 +- src/submodules/DiffusionMatrix/src/DM_9.inc | 4 +- .../src/DiffusionMatrix_Method@Methods.F90 | 41 +++--- .../ElasticNitscheMatrix_Method@Matrix1.F90 | 22 +-- .../ElasticNitscheMatrix_Method@Matrix3.F90 | 11 +- ...asticNitscheMatrix_Method@MatrixNormal.F90 | 4 +- ...sticNitscheMatrix_Method@MatrixTangent.F90 | 2 +- .../ElemshapeData_InterpolMethods@Methods.F90 | 14 +- ...hapeData_MatrixInterpolMethods@Methods.F90 | 8 +- ...lemshapeData_ProjectionMethods@Methods.F90 | 8 +- ...hapeData_ScalarInterpolMethods@Methods.F90 | 58 ++++---- ...peData_StabilizationParamMethods@SUGN3.F90 | 4 +- ...apeData_StabilizationParamMethods@SUPG.F90 | 16 +-- ...StabilizationParamMethods@Takizawa2018.F90 | 4 +- ...lemshapeData_UnitNormalMethods@Methods.F90 | 12 +- ...hapeData_VectorInterpolMethods@Methods.F90 | 12 +- ...acetMatrix_Method@FacetMatrix11Methods.F90 | 27 +--- ...acetMatrix_Method@FacetMatrix12Methods.F90 | 8 +- ...acetMatrix_Method@FacetMatrix13Methods.F90 | 8 +- ...acetMatrix_Method@FacetMatrix14Methods.F90 | 8 +- ...acetMatrix_Method@FacetMatrix15Methods.F90 | 16 +-- ...FacetMatrix_Method@FacetMatrix1Methods.F90 | 20 +-- ...acetMatrix_Method@FacetMatrix21Methods.F90 | 2 +- ...acetMatrix_Method@FacetMatrix22Methods.F90 | 2 +- ...FacetMatrix_Method@FacetMatrix2Methods.F90 | 12 +- ...FacetMatrix_Method@FacetMatrix3Methods.F90 | 8 +- ...FacetMatrix_Method@FacetMatrix4Methods.F90 | 8 +- ...FacetMatrix_Method@FacetMatrix5Methods.F90 | 46 ++----- .../src/ForceVector_Method@Methods.F90 | 20 +-- src/submodules/MassMatrix/src/MM_1.inc | 2 +- src/submodules/MassMatrix/src/MM_2a.inc | 2 +- src/submodules/MassMatrix/src/MM_2b.inc | 2 +- src/submodules/MassMatrix/src/MM_2c.inc | 2 +- src/submodules/MassMatrix/src/MM_2d.inc | 2 +- src/submodules/MassMatrix/src/MM_3.inc | 2 +- .../src/MassMatrix_Method@Methods.F90 | 21 ++- .../STConvectiveMatrix/src/STCM_10.inc | 4 +- .../STConvectiveMatrix/src/STCM_11.inc | 4 +- .../STConvectiveMatrix/src/STCM_12.inc | 4 +- .../STConvectiveMatrix/src/STCM_13.inc | 9 +- .../STConvectiveMatrix/src/STCM_14.inc | 9 +- .../STConvectiveMatrix/src/STCM_15.inc | 17 ++- .../STConvectiveMatrix/src/STCM_16.inc | 17 ++- .../STConvectiveMatrix/src/STCM_17.inc | 17 ++- .../STConvectiveMatrix/src/STCM_2.inc | 4 +- .../STConvectiveMatrix/src/STCM_3.inc | 4 +- .../STConvectiveMatrix/src/STCM_4.inc | 4 +- .../STConvectiveMatrix/src/STCM_5.inc | 4 +- .../STConvectiveMatrix/src/STCM_9.inc | 4 +- .../STDiffusionMatrix/src/STDM_1.inc | 2 +- .../STDiffusionMatrix/src/STDM_11.inc | 4 +- .../STDiffusionMatrix/src/STDM_12.inc | 5 +- .../STDiffusionMatrix/src/STDM_13.inc | 8 +- .../STDiffusionMatrix/src/STDM_14.inc | 8 +- .../STDiffusionMatrix/src/STDM_3.inc | 2 +- .../STDiffusionMatrix/src/STDM_5.inc | 4 +- .../STDiffusionMatrix/src/STDM_6.inc | 4 +- .../STDiffusionMatrix/src/STDM_7.inc | 2 +- .../STDiffusionMatrix/src/STDM_8.inc | 4 +- .../src/STDiffusionMatrix_Method@Methods.F90 | 42 +++--- src/submodules/STForceVector/src/STFV_10.inc | 2 +- src/submodules/STForceVector/src/STFV_11.inc | 2 +- src/submodules/STForceVector/src/STFV_12.inc | 4 +- src/submodules/STForceVector/src/STFV_13.inc | 4 +- src/submodules/STForceVector/src/STFV_14.inc | 4 +- src/submodules/STForceVector/src/STFV_16.inc | 2 +- src/submodules/STForceVector/src/STFV_17.inc | 2 +- src/submodules/STForceVector/src/STFV_18.inc | 2 +- src/submodules/STForceVector/src/STFV_19.inc | 4 +- src/submodules/STForceVector/src/STFV_2.inc | 2 +- src/submodules/STForceVector/src/STFV_20.inc | 4 +- src/submodules/STForceVector/src/STFV_21.inc | 4 +- src/submodules/STForceVector/src/STFV_3.inc | 2 +- src/submodules/STForceVector/src/STFV_4.inc | 2 +- src/submodules/STForceVector/src/STFV_5.inc | 4 +- src/submodules/STForceVector/src/STFV_6.inc | 4 +- src/submodules/STForceVector/src/STFV_7.inc | 4 +- src/submodules/STForceVector/src/STFV_9.inc | 2 +- .../src/STForceVector_Method@Methods.F90 | 36 ++--- src/submodules/STMassMatrix/src/STMM_10.inc | 2 +- src/submodules/STMassMatrix/src/STMM_11.inc | 2 +- src/submodules/STMassMatrix/src/STMM_12.inc | 2 +- src/submodules/STMassMatrix/src/STMM_13.inc | 2 +- src/submodules/STMassMatrix/src/STMM_14.inc | 2 +- src/submodules/STMassMatrix/src/STMM_15.inc | 2 +- src/submodules/STMassMatrix/src/STMM_16.inc | 2 +- .../STMassMatrix/src/STMM_17_20.inc | 4 +- src/submodules/STMassMatrix/src/STMM_21.inc | 4 +- src/submodules/STMassMatrix/src/STMM_22.inc | 4 +- src/submodules/STMassMatrix/src/STMM_23.inc | 6 +- src/submodules/STMassMatrix/src/STMM_24.inc | 4 +- src/submodules/STMassMatrix/src/STMM_25.inc | 4 +- src/submodules/STMassMatrix/src/STMM_26.inc | 4 +- src/submodules/STMassMatrix/src/STMM_27.inc | 4 +- src/submodules/STMassMatrix/src/STMM_28.inc | 4 +- src/submodules/STMassMatrix/src/STMM_5.inc | 2 +- src/submodules/STMassMatrix/src/STMM_6.inc | 2 +- src/submodules/STMassMatrix/src/STMM_7.inc | 2 +- src/submodules/STMassMatrix/src/STMM_8.inc | 2 +- src/submodules/STMassMatrix/src/STMM_9.inc | 2 +- .../src/STMassMatrix_Method@Methods.F90 | 128 +++++++++--------- .../src/StiffnessMatrix_Method@Methods.F90 | 12 +- 117 files changed, 539 insertions(+), 585 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index 66c173b8f..4e4b939f5 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -47,9 +47,9 @@ MODULE ElemshapeData_InterpolMethods ! - The `vartype` of val can be constant, space, time, spacetime ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val) + MODULE PURE SUBROUTINE master_getInterpolation_1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: interpol + TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE master_getInterpolation_1 END INTERFACE GetInterpolation @@ -75,9 +75,9 @@ END SUBROUTINE master_getInterpolation_1 ! - The `vartype` of val can be constant, space, time, spacetime ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val) + MODULE PURE SUBROUTINE master_getInterpolation_2(obj, ans, val) 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 END INTERFACE GetInterpolation @@ -92,7 +92,7 @@ END SUBROUTINE master_getInterpolation_2 ! summary: Interpolation of FEVariable INTERFACE - MODULE PURE FUNCTION master_interpolation_1(obj, val) RESULT(Ans) + MODULE PURE FUNCTION master_interpolation_1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(IN) :: val TYPE(FEVariable_) :: ans diff --git a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 index 52b7110e2..8d166e754 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 @@ -37,9 +37,9 @@ MODULE ElemshapeData_MatrixInterpolMethods ! summary: This subroutine performs interpolation of matrix INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val) + MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) !! interpolation of matrix REAL(DFP), INTENT(IN) :: val(:, :, :) !! nodal value of matrix @@ -55,10 +55,10 @@ END SUBROUTINE matrix_getInterpolation_1 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, interpol, val, & + MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, ans, val, & dim1, dim2, dim3) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) REAL(DFP), INTENT(IN) :: val(:, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 END SUBROUTINE matrix_getInterpolation1_ @@ -78,9 +78,9 @@ END SUBROUTINE matrix_getInterpolation1_ ! nodal values INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, interpol, val) + MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :) REAL(DFP), INTENT(IN) :: val(:, :, :, :) !! space-time nodal value of matrix END SUBROUTINE matrix_getInterpolation_2 @@ -95,10 +95,10 @@ END SUBROUTINE matrix_getInterpolation_2 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, interpol, val, & + MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, ans, val, & dim1, dim2, dim3) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) REAL(DFP), INTENT(IN) :: val(:, :, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 END SUBROUTINE matrix_getInterpolation2_ @@ -118,9 +118,9 @@ END SUBROUTINE matrix_getInterpolation2_ ! nodal values INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val) + MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :, :) !! space-time interpolation REAL(DFP), INTENT(IN) :: val(:, :, :, :) !! space-time nodal value of matrix @@ -136,9 +136,9 @@ END SUBROUTINE matrix_getInterpolation_3 ! summary: This subroutine performs interpolation of matrix FEVariable ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val) + MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) !! interpolation of matrix TYPE(FEVariable_), INTENT(IN) :: val !! matrix fe variable @@ -154,10 +154,10 @@ END SUBROUTINE matrix_getInterpolation_4 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, interpol, val, & + MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, ans, val, & dim1, dim2, dim3) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 END SUBROUTINE matrix_getInterpolation4_ @@ -168,9 +168,9 @@ END SUBROUTINE matrix_getInterpolation4_ !---------------------------------------------------------------------------- INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val) + MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) !! space-time interpolation of matrix TYPE(FEVariable_), INTENT(IN) :: val !! matrix fe variable @@ -186,10 +186,10 @@ END SUBROUTINE matrix_getInterpolation_5 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, interpol, val, & + MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, ans, val, & dim1, dim2, dim3, dim4) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 END SUBROUTINE matrix_getInterpolation5_ @@ -204,10 +204,10 @@ END SUBROUTINE matrix_getInterpolation5_ ! summary: This function returns the interpolation of matrix INTERFACE - MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(interpol) + MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) - REAL(DFP), ALLOCATABLE :: interpol(:, :, :) + REAL(DFP), ALLOCATABLE :: ans(:, :, :) END FUNCTION matrix_interpolation_1 END INTERFACE @@ -231,11 +231,11 @@ END FUNCTION matrix_interpolation_1 INTERFACE - MODULE PURE FUNCTION matrix_stinterpolation_1(obj, val) RESULT(interpol) + MODULE PURE FUNCTION matrix_stinterpolation_1(obj, val) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :, :) !! spatial nodal values of matrix - REAL(DFP), ALLOCATABLE :: interpol(:, :, :) + REAL(DFP), ALLOCATABLE :: ans(:, :, :) !! Interpolation value of matrix END FUNCTION matrix_stinterpolation_1 END INTERFACE diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 index 941d8d078..2fbb97278 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 @@ -46,9 +46,9 @@ MODULE ElemshapeData_ScalarInterpolMethods ! - TODO Make it work when the size of val is not the same as NNS INTERFACE GetInterpolation - MODULE PURE SUBROUTINE GetInterpolation1(obj, interpol, val) + MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) CLASS(ElemShapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:) !! Interpolation value of of scalar REAL(DFP), INTENT(IN) :: val(:) !! spatial nodal values of scalar @@ -64,9 +64,9 @@ END SUBROUTINE GetInterpolation1 ! summary: get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_1(obj, interpol, val, tsize) + MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, tsize) CLASS(ElemShapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(INOUT) :: ans(:) REAL(DFP), INTENT(IN) :: val(:) INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE GetInterpolation_1 @@ -81,11 +81,11 @@ END SUBROUTINE GetInterpolation_1 ! summary: get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_1a(obj, interpol, val, & + MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, & tsize, scale, & addContribution) CLASS(ElemShapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(INOUT) :: ans(:) REAL(DFP), INTENT(IN) :: val(:) INTEGER(I4B), INTENT(OUT) :: tsize REAL(DFP), INTENT(IN) :: scale @@ -112,9 +112,9 @@ END SUBROUTINE GetInterpolation_1a ! spatial-quadrature points INTERFACE GetInterpolation - MODULE PURE SUBROUTINE GetInterpolation2(obj, interpol, val) + MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) CLASS(STElemShapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:) !! Interpolation of scalar REAL(DFP), INTENT(IN) :: val(:, :) !! space-time nodal values of scalar @@ -135,9 +135,9 @@ END SUBROUTINE GetInterpolation2 ! This method is like GetInterpolation_2 but without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_2(obj, interpol, val, tsize) + MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, tsize) CLASS(STElemShapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(INOUT) :: ans(:) REAL(DFP), INTENT(IN) :: val(:, :) INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE GetInterpolation_2 @@ -156,11 +156,11 @@ END SUBROUTINE GetInterpolation_2 ! This method is like GetInterpolation_2 but without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_2a(obj, interpol, val, & + MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, & tsize, scale, & addContribution) CLASS(STElemShapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(INOUT) :: ans(:) REAL(DFP), INTENT(IN) :: val(:, :) INTEGER(I4B), INTENT(OUT) :: tsize REAL(DFP), INTENT(IN) :: scale @@ -187,9 +187,9 @@ END SUBROUTINE GetInterpolation_2a ! spatial-temporal quadrature points INTERFACE GetInterpolation - MODULE PURE SUBROUTINE GetInterpolation3(obj, interpol, val) + MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :) !! space-time Interpolation of scalar REAL(DFP), INTENT(IN) :: val(:, :) !! space-time nodal values of scalar @@ -205,10 +205,10 @@ END SUBROUTINE GetInterpolation3 ! summary: Get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_3(obj, interpol, val, & + MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, & nrow, ncol) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) REAL(DFP), INTENT(IN) :: val(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE GetInterpolation_3 @@ -223,11 +223,11 @@ END SUBROUTINE GetInterpolation_3 ! summary: Get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_3a(obj, interpol, val, & + MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, & nrow, ncol, scale, & addContribution) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) REAL(DFP), INTENT(IN) :: val(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol REAL(DFP), INTENT(IN) :: scale @@ -258,9 +258,9 @@ END SUBROUTINE GetInterpolation_3a !@endnote INTERFACE GetInterpolation - MODULE PURE SUBROUTINE GetInterpolation4(obj, interpol, val) + MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:) !! interpolation of scalar TYPE(FEVariable_), INTENT(IN) :: val !! Scalar FE variable @@ -276,9 +276,9 @@ END SUBROUTINE GetInterpolation4 ! summary: get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_4(obj, interpol, val, tsize) + MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, tsize) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(INOUT) :: ans(:) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE GetInterpolation_4 @@ -293,10 +293,10 @@ END SUBROUTINE GetInterpolation_4 ! summary: get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_4a(obj, interpol, val, tsize, & + MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, tsize, & scale, addContribution, timeIndx) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + REAL(DFP), INTENT(INOUT) :: ans(:) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: tsize REAL(DFP), INTENT(IN) :: scale @@ -329,9 +329,9 @@ END SUBROUTINE GetInterpolation_4a ! spatial-quadrature points INTERFACE GetInterpolation - MODULE PURE SUBROUTINE GetInterpolation5(obj, interpol, val) + MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! space-time interpolation of scalar TYPE(FEVariable_), INTENT(IN) :: val !! scalar FE variable @@ -347,10 +347,10 @@ END SUBROUTINE GetInterpolation5 ! summary: get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_5(obj, interpol, val, & + MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, & nrow, ncol) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE GetInterpolation_5 @@ -365,11 +365,11 @@ END SUBROUTINE GetInterpolation_5 ! summary: Get interpolation of scalar without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE GetInterpolation_5a(obj, interpol, val, & + MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, & nrow, ncol, scale, & addContribution) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: nrow, ncol REAL(DFP), INTENT(IN) :: scale @@ -386,10 +386,10 @@ END SUBROUTINE GetInterpolation_5a ! summary: This function returns the interpolation of a scalar INTERFACE Interpolation - MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(interpol) + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:) - REAL(DFP), ALLOCATABLE :: interpol(:) + REAL(DFP), ALLOCATABLE :: ans(:) END FUNCTION Interpolation1 END INTERFACE Interpolation @@ -410,11 +410,11 @@ END FUNCTION Interpolation1 ! $$u=u^{a}_{I}N^{I}T_{a}$$ INTERFACE - MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(interpol) + 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 :: interpol(:) + REAL(DFP), ALLOCATABLE :: ans(:) !! Interpolation value of `val` at integration points END FUNCTION STInterpolation1 END INTERFACE diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 index 63f29944d..e2926f25a 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 @@ -44,9 +44,9 @@ MODULE ElemshapeData_VectorInterpolMethods ! $$u_{i}=u_{iI}N^{I}$$ INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val) + MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! interpolation of vector REAL(DFP), INTENT(IN) :: val(:, :) !! nodal values of vector in `xiJ` format @@ -62,10 +62,10 @@ END SUBROUTINE vector_getInterpolation_1 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation1_(obj, interpol, val, & + MODULE PURE SUBROUTINE vector_getInterpolation1_(obj,ans, val, & nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) REAL(DFP), INTENT(IN) :: val(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE vector_getInterpolation1_ @@ -87,9 +87,9 @@ END SUBROUTINE vector_getInterpolation1_ ! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val) + MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :) !! REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time nodal values of vector in `xiJa` format @@ -105,10 +105,10 @@ END SUBROUTINE vector_getInterpolation_2 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, interpol, val, & + MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, ans, val, & nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) REAL(DFP), INTENT(IN) :: val(:, :, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE vector_getInterpolation2_ @@ -130,9 +130,9 @@ END SUBROUTINE vector_getInterpolation2_ ! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val) + MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE ::ans(:, :, :) !! REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time nodal values of vector in `xiJa` format @@ -148,10 +148,10 @@ END SUBROUTINE vector_getInterpolation_3 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation3_(obj, interpol, val, & + MODULE PURE SUBROUTINE vector_getInterpolation3_(obj,ans, val, & dim1, dim2, dim3) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT) ::ans(:, :, :) REAL(DFP), INTENT(IN) :: val(:, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 END SUBROUTINE vector_getInterpolation3_ @@ -178,9 +178,9 @@ END SUBROUTINE vector_getInterpolation3_ ! NOTE This routine calls [[Interpolation]] function from the same module. ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val) + MODULE PURE SUBROUTINE vector_getInterpolation_4(obj,ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) !! interpolation of vector TYPE(FEVariable_), INTENT(IN) :: val !! vector FEvariable @@ -196,10 +196,10 @@ END SUBROUTINE vector_getInterpolation_4 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, interpol, val, & + MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, ans, val, & nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE vector_getInterpolation4_ @@ -226,9 +226,9 @@ END SUBROUTINE vector_getInterpolation4_ ! NOTE This routine calls [[Interpolation]] function from the same module. ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val) + MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) !! space-time interpolation of vector TYPE(FEVariable_), INTENT(IN) :: val !! vector FEvariable @@ -244,10 +244,10 @@ END SUBROUTINE vector_getInterpolation_5 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation5_(obj, interpol, val, & + MODULE PURE SUBROUTINE vector_getInterpolation5_(obj, ans, val, & dim1, dim2, dim3) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) TYPE(FEVariable_), INTENT(IN) :: val INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 END SUBROUTINE vector_getInterpolation5_ @@ -262,10 +262,10 @@ END SUBROUTINE vector_getInterpolation5_ ! summary: This function returns the interpolation of vector INTERFACE - MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(interpol) + MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:, :) - REAL(DFP), ALLOCATABLE :: interpol(:, :) + REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION vector_interpolation_1 END INTERFACE @@ -286,11 +286,11 @@ END FUNCTION vector_interpolation_1 ! values. ! $$u=u^{a}_{I}N^{I}T_{a}$$ - MODULE PURE FUNCTION vector_stinterpolation_1(obj, val) RESULT(interpol) + MODULE PURE FUNCTION vector_stinterpolation_1(obj, val) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) !! spatial nodal values of vector - REAL(DFP), ALLOCATABLE :: interpol(:, :) + REAL(DFP), ALLOCATABLE :: ans(:, :) !! Interpolation value of vector END FUNCTION vector_stinterpolation_1 END INTERFACE diff --git a/src/submodules/ConvectiveMatrix/src/CM_3.inc b/src/submodules/ConvectiveMatrix/src/CM_3.inc index 4095c3ac6..e6f7207a5 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_3.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_3.inc @@ -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/CM_4.inc index 91c1be600..5dfd5daf9 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_4.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_4.inc @@ -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/CM_5.inc index 572670b68..987058f70 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_5.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_5.inc @@ -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 !! diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/CM_6.inc index c260ddaa5..82afeb95c 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_6.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_6.inc @@ -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 !! diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 index bad5cdb52..6eb09e54e 100644 --- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 +++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 @@ -273,7 +273,7 @@ PURE SUBROUTINE CM3_(ans, test, trial, term1, term2, c, opt, nrow, ncol) ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + 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 @@ -311,7 +311,7 @@ PURE SUBROUTINE CM4_(ans, test, trial, term1, term2, c, opt, nrow, ncol) ncol = SIZE(trial%N, 1) ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + 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 @@ -347,7 +347,7 @@ PURE SUBROUTINE CM5_(ans, test, trial, term1, term2, c, opt, nrow, ncol) REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd) REAL(DFP), PARAMETER :: one = 1.0_DFP - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + 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 @@ -400,7 +400,7 @@ PURE SUBROUTINE CM6_(ans, test, trial, term1, term2, c, opt, nrow, ncol) nrow = test%nns ncol = trial%nns - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + 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 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 358c371d7..659def2fb 100644 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -77,7 +77,7 @@ MODULE PROCEDURE DiffusionMatrix_2 REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) INTEGER(I4B) :: ii -CALL GetInterpolation(obj=trial, Interpol=kbar, val=k) +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) @@ -96,7 +96,7 @@ REAL(DFP) :: realval, kbar(trial%nips) INTEGER(I4B) :: ii -CALL GetInterpolation_(obj=trial, Interpol=kbar, val=k, tsize=ii) +CALL GetInterpolation_(obj=trial, ans=kbar, val=k, tsize=ii) nrow = test%nns ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0 @@ -172,7 +172,7 @@ REAL(DFP), ALLOCATABLE :: kbar(:, :, :) REAL(DFP), ALLOCATABLE :: realval(:) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=kbar, val=k) +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) @@ -194,7 +194,7 @@ REAL(DFP), PARAMETER :: one = 1.0_DFP INTEGER(I4B) :: ii, jj, kk -CALL getInterpolation_(obj=trial, Interpol=kbar, val=k, & +CALL getInterpolation_(obj=trial, ans=kbar, val=k, & dim1=ii, dim2=jj, dim3=kk) nrow = test%nns ncol = trial%nns @@ -222,8 +222,8 @@ MODULE PROCEDURE DiffusionMatrix_5 REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) INTEGER(I4B) :: ii -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) @@ -242,8 +242,8 @@ REAL(DFP) :: realval(trial%nips), cbar(trial%nips) INTEGER(I4B) :: ii -CALL getInterpolation_(obj=trial, Interpol=cbar, val=c1, tsize=ii) -CALL getInterpolation_(obj=trial, Interpol=realval, val=c2, tsize=ii) +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 @@ -273,7 +273,7 @@ INTEGER(I4B) :: ii CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) -CALL getInterpolation(obj=trial, interpol=realval, val=c1) +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) @@ -298,7 +298,7 @@ CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=c2, & nrow=ncol, ncol=ii) -CALL getInterpolation_(obj=trial, interpol=realval, val=c1, & +CALL getInterpolation_(obj=trial, ans=realval, val=c1, & tsize=ii) realval = realval * trial%js * trial%ws * trial%thickness @@ -327,8 +327,9 @@ REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: kbar(:, :, :) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=realval, val=c1) -CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) + +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(& @@ -384,8 +385,8 @@ REAL(DFP), ALLOCATABLE :: realval(:) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) -CALL getInterpolation(obj=trial, interpol=matbar, val=c2) +CALL 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)) @@ -427,8 +428,8 @@ REAL(DFP), ALLOCATABLE :: realval(:) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, interpol=matbar, val=c1) -CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) +CALL 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)) @@ -452,8 +453,8 @@ MODULE PROCEDURE DiffusionMatrix_13 REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) -CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) +CALL 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) @@ -559,7 +560,7 @@ PURE SUBROUTINE DiffusionMatrix_15a(test, trial, k, ans) INTEGER(I4B) :: ii, jj, nsd, ips nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + 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 @@ -589,7 +590,7 @@ PURE SUBROUTINE DiffusionMatrix_15b(test, trial, k, ans) INTEGER(I4B) :: ii, jj, nsd, ips nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + 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 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 index 4d43bd2a3..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) @@ -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@Matrix3.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 index 0424b6a0f..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) @@ -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 diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 index 3a5fb73d3..3fc5a008f 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 @@ -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/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index 144aa6ea9..8e3756378 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -39,17 +39,17 @@ ! !! ! SELECT CASE (val%rank) ! CASE (Scalar) -! CALL getInterpolation(obj=obj, interpol=r1, val=val) +! CALL getInterpolation(obj=obj, ans=r1, val=val) ! interpol = QuadratureVariable(r1, typeFEVariableScalar, & ! & typeFEVariableSpace) ! DEALLOCATE (r1) ! CASE (Vector) -! CALL getInterpolation(obj=obj, interpol=r2, val=val) +! CALL getInterpolation(obj=obj, ans=r2, val=val) ! interpol = QuadratureVariable(r2, typeFEVariableVector, & ! & typeFEVariableSpace) ! DEALLOCATE (r2) ! CASE (Matrix) -! CALL getInterpolation(obj=obj, interpol=r3, val=val) +! CALL getInterpolation(obj=obj, ans=r3, val=val) ! interpol = QuadratureVariable(r3, typeFEVariableMatrix, & ! & typeFEVariableSpace) ! DEALLOCATE (r3) @@ -75,17 +75,17 @@ ! !! ! SELECT CASE (val%rank) ! CASE (Scalar) -! CALL getInterpolation(obj=obj, interpol=r2, val=val) +! CALL getInterpolation(obj=obj, ans=r2, val=val) ! interpol = QuadratureVariable(r2, typeFEVariableScalar, & ! & typeFEVariableSpaceTime) ! DEALLOCATE (r2) ! CASE (Vector) -! CALL getInterpolation(obj=obj, interpol=r3, val=val) +! CALL getInterpolation(obj=obj, ans=r3, val=val) ! interpol = QuadratureVariable(r3, typeFEVariableVector, & ! & typeFEVariableSpaceTime) ! DEALLOCATE (r3) ! CASE (Matrix) -! CALL getInterpolation(obj=obj, interpol=r4, val=val) +! CALL getInterpolation(obj=obj, ans=r4, val=val) ! interpol = QuadratureVariable(r4, typeFEVariableMatrix, & ! & typeFEVariableSpaceTime) ! DEALLOCATE (r4) @@ -98,7 +98,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE master_interpolation_1 -! CALL getInterpolation(obj=obj, val=val, interpol=ans) +! CALL getInterpolation(obj=obj, val=val, ans=ans) END PROCEDURE master_interpolation_1 END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 index 6477e5d36..518a043fc 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 @@ -128,7 +128,7 @@ ! CALL GetInterpolation_(obj=obj, & ! val=Get(val, TypeFEVariableMatrix, & ! TypeFEVariableSpace), & -! interpol=interpol, & +! ans=interpol, & ! dim1=dim1, dim2=dim2, dim3=dim3) ! ELSE ! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & @@ -142,7 +142,7 @@ ! CALL GetInterpolation_(obj=obj, & ! val=Get(val, TypeFEVariableMatrix, & ! TypeFEVariableSpaceTime), & -! interpol=interpol, & +! ans=interpol, & ! dim1=dim1, dim2=dim2, dim3=dim3) ! END IF ! END SELECT @@ -253,7 +253,7 @@ ! CALL GetInterpolation_(obj=obj(ii), & ! val=Get(val, TypeFEVariableMatrix, & ! TypeFEVariableSpace), & -! interpol=interpol(:, :, :, ii), & +! ans=interpol(:, :, :, ii), & ! dim1=dim1, dim2=dim2, dim3=dim3) ! END DO ! ELSE @@ -271,7 +271,7 @@ ! CALL GetInterpolation_(obj=obj(ii), & ! val=Get(val, TypeFEVariableMatrix, & ! TypeFEVariableSpaceTime), & -! interpol=interpol(:, :, :, ii), & +! ans=interpol(:, :, :, ii), & ! dim1=dim1, dim2=dim2, dim3=dim3) ! END DO ! ELSE diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index c4819ecda..15e24589b 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -65,7 +65,7 @@ !! !! main !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) +CALL getInterpolation(obj=obj, val=val, ans=cbar) CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3)) nsd = SIZE(obj%dNdXt, 2) DO ii = 1, SIZE(cdNdXt, 2) @@ -84,7 +84,7 @@ INTEGER(I4B) :: ii, nsd REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) -CALL GetInterpolation_(obj=obj, val=val, interpol=cbar, nrow=nrow, ncol=ncol) +CALL GetInterpolation_(obj=obj, val=val, ans=cbar, nrow=nrow, ncol=ncol) nsd = nrow nrow = SIZE(obj%dNdXt, 1) @@ -159,7 +159,7 @@ !! !! main !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) +CALL getInterpolation(obj=obj, val=val, ans=cbar) CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & & SIZE(obj%dNTdXt, 4)) nsd = SIZE(obj%dNTdXt, 3) @@ -182,7 +182,7 @@ !! !! main !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) +CALL getInterpolation(obj=obj, val=val, ans=cbar) !! CALL Reallocate(cdNTdXt, & & SIZE(obj(1)%dNTdXt, 1), & diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 index 1e46b5ce8..ed0d117ef 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 @@ -30,8 +30,8 @@ MODULE PROCEDURE GetInterpolation1 INTEGER(I4B) :: tsize -CALL Reallocate(interpol, obj%nips) -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, & +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) END PROCEDURE GetInterpolation1 @@ -40,7 +40,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_1 -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, & +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) END PROCEDURE GetInterpolation_1 @@ -55,12 +55,12 @@ valNNS = SIZE(val) minNNS = MIN(valNNS, obj%nns) -IF (.NOT. addContribution) interpol(1:tsize) = 0.0_DFP +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP -! interpol(1:obj%nips) = MATMUL(val(1:minNNS), obj%N(1:minNNS, 1:obj%nips)) +!ans(1:obj%nips) = MATMUL(val(1:minNNS), obj%N(1:minNNS, 1:obj%nips)) DO ips = 1, obj%nips DO ii = 1, minNNS - interpol(ips) = interpol(ips) + scale * val(ii) * obj%N(ii, ips) + ans(ips) = ans(ips) + scale * val(ii) * obj%N(ii, ips) END DO END DO END PROCEDURE GetInterpolation_1a @@ -71,8 +71,8 @@ MODULE PROCEDURE GetInterpolation2 INTEGER(I4B) :: tsize -CALL Reallocate(interpol, obj%nips) -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, & +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) END PROCEDURE GetInterpolation2 @@ -81,7 +81,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_2 -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, & +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) END PROCEDURE GetInterpolation_2 @@ -97,11 +97,11 @@ valNNT = SIZE(val, 2) minNNT = MIN(valNNT, obj%nnt) -IF (.NOT. addContribution) interpol(1:obj%nips) = 0.0_DFP +IF (.NOT. addContribution) ans(1:obj%nips) = 0.0_DFP DO aa = 1, minNNT myscale = obj%T(aa) * scale - CALL GetInterpolation_(obj=obj, interpol=interpol, val=val(:, aa), & + CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, aa), & tsize=tsize, scale=myscale, addContribution=.TRUE.) END DO END PROCEDURE GetInterpolation_2a @@ -115,8 +115,8 @@ nrow = obj(1)%nips ncol = SIZE(obj) -CALL Reallocate(interpol, nrow, ncol) -CALL GetInterpolation_(obj=obj, interpol=interpol, & +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 @@ -126,7 +126,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_3 -CALL GetInterpolation_(obj=obj, interpol=interpol, & +CALL GetInterpolation_(obj=obj, ans=ans, & val=val, nrow=nrow, ncol=ncol, scale=1.0_DFP, & addContribution=.FALSE.) END PROCEDURE GetInterpolation_3 @@ -142,7 +142,7 @@ ncol = SIZE(obj) DO ipt = 1, ncol - CALL GetInterpolation_(obj=obj(ipt), interpol=interpol(:, ipt), & + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, ipt), & val=val, tsize=nrow, scale=scale, & addContribution=addContribution) END DO @@ -154,8 +154,8 @@ MODULE PROCEDURE GetInterpolation4 INTEGER(I4B) :: tsize -CALL Reallocate(interpol, obj%nips) -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, tsize=tsize) +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize) END PROCEDURE GetInterpolation4 !---------------------------------------------------------------------------- @@ -165,7 +165,7 @@ MODULE PROCEDURE GetInterpolation_4 REAL(DFP), PARAMETER :: one = 1.0_DFP LOGICAL(LGT), PARAMETER :: no = .FALSE. -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, tsize=tsize, & +CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, & scale=one, addContribution=no) END PROCEDURE GetInterpolation_4 @@ -186,7 +186,7 @@ N=obj%N, nns=obj%nns, nips=obj%nips, & scale=scale, & addContribution=addContribution, & - ans=interpol, tsize=tsize) + ans=ans, tsize=tsize) CASE (TypeFEVariableOpt%space) CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & @@ -194,7 +194,7 @@ N=obj%N, nns=obj%nns, nips=obj%nips, & scale=scale, & addContribution=addContribution, & - ans=interpol, tsize=tsize) + ans=ans, tsize=tsize) CASE (TypeFEVariableOpt%spacetime) SELECT TYPE (obj); TYPE IS (STElemShapeData_) @@ -204,7 +204,7 @@ T=obj%T, nnt=obj%nnt, & scale=scale, & addContribution=addContribution, & - ans=interpol, tsize=tsize, & + ans=ans, tsize=tsize, & timeIndx=timeIndx0) END SELECT @@ -223,8 +223,8 @@ nrow = obj(1)%nips ncol = SIZE(obj) -CALL Reallocate(interpol, nrow, ncol) -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, nrow=nrow, & +CALL Reallocate(ans, nrow, ncol) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, & ncol=ncol, scale=one, addContribution=no) END PROCEDURE GetInterpolation5 @@ -236,7 +236,7 @@ REAL(DFP), PARAMETER :: one = 1.0_DFP LOGICAL(LGT), PARAMETER :: no = .FALSE. -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, nrow=nrow, & +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, & ncol=ncol, scale=one, addContribution=no) END PROCEDURE GetInterpolation_5 @@ -251,7 +251,7 @@ ncol = SIZE(obj) DO ipt = 1, ncol - CALL GetInterpolation_(obj=obj(ipt), interpol=interpol(:, ipt), & + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, ipt), & val=val, tsize=nrow, scale=scale, & addContribution=addContribution, timeIndx=ipt) END DO @@ -265,8 +265,8 @@ REAL(DFP), PARAMETER :: one = 1.0_DFP LOGICAL(LGT), PARAMETER :: no = .FALSE. INTEGER(I4B) :: tsize -CALL Reallocate(interpol, obj%nips) -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, tsize=tsize, & +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, & scale=one, addContribution=no) END PROCEDURE Interpolation1 @@ -278,8 +278,8 @@ REAL(DFP), PARAMETER :: one = 1.0_DFP LOGICAL(LGT), PARAMETER :: no = .FALSE. INTEGER(I4B) :: tsize -CALL Reallocate(interpol, obj%nips) -CALL GetInterpolation_(obj=obj, interpol=interpol, val=val, tsize=tsize, & +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, & scale=one, addContribution=no) END PROCEDURE STInterpolation1 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..d1e6fe30b 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 @@ -76,11 +76,11 @@ PURE SUBROUTINE elemsd_getSUPGParam_a(obj, tau, c, val, nu, k, & rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) !! - 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 +129,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 @@ -183,11 +183,11 @@ 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 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))) @@ -399,7 +399,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 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 15aa50970..ab2ba6137 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 @@ -29,7 +29,7 @@ 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%nsd, obj%nips) pnorm = NORM2(dp, DIM=1) @@ -62,7 +62,7 @@ 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) @@ -106,9 +106,9 @@ PURE SUBROUTINE scalar_getUnitNormal_3(obj, r, 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 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) !! @@ -140,7 +140,7 @@ PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val) 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) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 index 57fc49a9c..cbe0be749 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 @@ -26,7 +26,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE vector_getinterpolation_1 -interpol = MATMUL(val, obj%N) +ans = MATMUL(val, obj%N) END PROCEDURE vector_getinterpolation_1 !---------------------------------------------------------------------------- @@ -36,7 +36,7 @@ MODULE PROCEDURE vector_getinterpolation1_ nrow = SIZE(val, 1) ncol = SIZE(obj%N, 2) -interpol(1:nrow, 1:ncol) = MATMUL(val, obj%N) +ans(1:nrow, 1:ncol) = MATMUL(val, obj%N) END PROCEDURE vector_getinterpolation1_ !---------------------------------------------------------------------------- @@ -160,7 +160,7 @@ ! CALL GetInterpolation_(obj=obj, & ! val=Get(val, TypeFEVariableVector, & ! TypeFEVariableSpace), & -! interpol=interpol, & +! ans=interpol, & ! nrow=nrow, ncol=ncol) ! ELSE ! CALL Get_(obj=val, rank=TypeFEVariableVector, & @@ -173,7 +173,7 @@ ! CALL GetInterpolation_(obj=obj, & ! val=Get(val, TypeFEVariableVector, & ! TypeFEVariableSpaceTime), & -! interpol=interpol, & +! ans=interpol, & ! nrow=nrow, ncol=ncol) ! END SELECT ! END SELECT @@ -278,7 +278,7 @@ ! CALL GetInterpolation_(obj=obj(ii), & ! val=Get(val, TypeFEVariableVector, & ! TypeFEVariableSpace), & -! interpol=interpol(1:dim1, 1:dim2, ii), & +! ans=interpol(1:dim1, 1:dim2, ii), & ! nrow=dim1, ncol=dim2) ! END DO ! ELSE @@ -295,7 +295,7 @@ ! CALL GetInterpolation_(obj=obj(ii), & ! val=Get(val, TypeFEVariableVector, & ! TypeFEVariableSpaceTime), & -! interpol=interpol(1:dim1, 1:dim2, ii), & +! ans=interpol(1:dim1, 1:dim2, ii), & ! nrow=dim1, ncol=dim2) ! END DO ! ELSE diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 index e6d2ef714..2fc69ccf0 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 @@ -149,7 +149,7 @@ & cdNdXt=slaveC1, & & val=slaveElemsd%normal) !! -CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! masterC1 = masterC1 * muMaster slaveC1 = slaveC1 * muSlave @@ -202,15 +202,9 @@ & cdNdXt=slaveC1, & & val=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) @@ -262,20 +256,11 @@ & cdNdXt=slaveC1, & & val=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) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 index 584a75829..7828f15f9 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 @@ -91,7 +91,7 @@ & obj=elemsd, & & cdNdXt=C1, & & 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 * mu * mu DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -116,7 +116,7 @@ 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, ans=muBar, val=mu) realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -142,8 +142,8 @@ 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) +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(:, :) & diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 index d48566e36..7c8d55afe 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 @@ -148,7 +148,7 @@ & 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 * mu * taubar !! @@ -199,7 +199,7 @@ & cdNdXt=masterC1, & & val=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 !! @@ -250,8 +250,8 @@ & cdNdXt=masterC1, & & val=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 index f9979feae..711f6c78b 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 @@ -146,7 +146,7 @@ & 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 * mu * taubar !! @@ -196,7 +196,7 @@ & cdNdXt=masterC1, & & val=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 !! @@ -246,8 +246,8 @@ & cdNdXt=masterC1, & & val=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 index 41aaef053..a4dec8f4f 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 @@ -279,12 +279,12 @@ !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=muMasterBar, & + & ans=muMasterBar, & & val=muMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=muSlaveBar, & + & ans=muSlaveBar, & & val=muSlave) !! DO ips = 1, nips @@ -360,12 +360,12 @@ !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=tauMasterBar, & + & ans=tauMasterBar, & & val=tauMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=tauSlaveBar, & + & ans=tauSlaveBar, & & val=tauSlave) !! masterC1 = muMaster * masterC1 @@ -447,22 +447,22 @@ !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=muMasterBar, & + & ans=muMasterBar, & & val=muMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=muSlaveBar, & + & ans=muSlaveBar, & & val=muSlave) !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=tauMasterBar, & + & ans=tauMasterBar, & & val=tauMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=tauSlaveBar, & + & ans=tauSlaveBar, & & val=tauSlave) !! DO ips = 1, nips diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 index cf3741f65..e936db88f 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 @@ -178,7 +178,7 @@ & cdNdXt=slaveC1, & & val=slaveElemSD%normal) !! -CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! i3 = eye(nsd) !! @@ -248,10 +248,10 @@ & 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, ans=muMasterBar, & + val=muMaster) +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, & + val=muSlave) !! i3 = eye(nsd) !! @@ -321,11 +321,11 @@ & cdNdXt=slaveC1, & & val=slaveElemSD%normal) !! -CALL getInterpolation(obj=masterElemSD, interpol=muMasterBar, & - & val=muMaster) -CALL getInterpolation(obj=slaveElemSD, interpol=muSlaveBar, & - & val=muSlave) -CALL getInterpolation(obj=masterElemSD, interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, & + val=muMaster) +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, & + val=muSlave) +CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! i3 = eye(nsd) !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 index 7c67006be..a354399bc 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 @@ -109,7 +109,7 @@ & 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 !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 index ef4a4f7ee..e509dccb4 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 @@ -109,7 +109,7 @@ & 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 !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 index bf1ab204f..5cc57ee29 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 @@ -135,7 +135,7 @@ 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 * mu * mu !! @@ -182,8 +182,8 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) -CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) +CALL GetProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) +CALL GetInterpolation(obj=elemsd, ans=muBar, val=mu) !! CALL Reallocate(G12, nns1, nsd, nsd) CALL Reallocate(m4, nns1, nns1, nsd, nsd) @@ -231,9 +231,9 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) -CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) -CALL getInterpolation(obj=elemsd, interpol=tauBar, val=tauvar) +CALL GetProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) +CALL GetInterpolation(obj=elemsd, ans=muBar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=tauBar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 index 9756a37c1..5d9eae67c 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 @@ -168,7 +168,7 @@ & 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 * mu * taubar !! @@ -228,7 +228,7 @@ & cdNdXt=masterC1, & & val=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 !! @@ -290,8 +290,8 @@ & cdNdXt=masterC1, & & val=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 index fa6f400a6..fd03adb8d 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 @@ -172,7 +172,7 @@ & 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 * mu * taubar !! @@ -234,7 +234,7 @@ & cdNdXt=masterC1, & & val=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 !! @@ -296,8 +296,8 @@ & cdNdXt=masterC1, & & val=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 index 7d5da6e4f..89943f008 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 @@ -323,15 +323,9 @@ & cdNdXt=slaveC1, & & val=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 masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) @@ -425,15 +419,9 @@ & cdNdXt=slaveC1, & & val=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 @@ -528,25 +516,13 @@ & 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) +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) diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index 1da09a0be..f72cb7f69 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -18,7 +18,7 @@ SUBMODULE(ForceVector_Method) Methods USE ReallocateUtility, ONLY: Reallocate USE ElemshapeData_Method, ONLY: GetInterpolation -use ProductUtility, only: OuterProd +USE ProductUtility, ONLY: OuterProd IMPLICIT NONE CONTAINS @@ -51,7 +51,7 @@ INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, interpol=realval, val=c) +CALL GetInterpolation(obj=test, ans=realval, val=c) realval = test%js * test%ws * test%thickness * realval CALL Reallocate(ans, SIZE(test%N, 1)) @@ -73,7 +73,7 @@ INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, interpol=cbar, val=c) +CALL GetInterpolation(obj=test, ans=cbar, val=c) realval = test%js * test%ws * test%thickness CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) @@ -95,7 +95,7 @@ INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, interpol=cbar, val=c) +CALL GetInterpolation(obj=test, ans=cbar, val=c) realval = test%js * test%ws * test%thickness CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), SIZE(test%N, 1)) @@ -118,8 +118,8 @@ INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c1bar, val=c1) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) realval = test%js * test%ws * test%thickness * c1bar * c2bar CALL Reallocate(ans, SIZE(test%N, 1)) @@ -142,8 +142,8 @@ INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c1bar, val=c1) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) realval = test%js * test%ws * test%thickness * c1bar CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test%N, 1)) @@ -166,8 +166,8 @@ INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c1bar, val=c1) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) realval = test%js * test%ws * test%thickness * c1bar CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test%N, 1)) diff --git a/src/submodules/MassMatrix/src/MM_1.inc b/src/submodules/MassMatrix/src/MM_1.inc index aee971caa..f286982d8 100644 --- a/src/submodules/MassMatrix/src/MM_1.inc +++ b/src/submodules/MassMatrix/src/MM_1.inc @@ -38,7 +38,7 @@ PURE SUBROUTINE MM_1(ans, test, trial, rho, opt) !! main !! CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - CALL getInterpolation(obj=trial, interpol=realval, val=rho) + CALL getInterpolation(obj=trial, ans=realval, val=rho) realval = trial%js * trial%ws * trial%thickness * realval !! DO ips = 1, size(realval) diff --git a/src/submodules/MassMatrix/src/MM_2a.inc b/src/submodules/MassMatrix/src/MM_2a.inc index 0c31616c7..d89b3e59f 100644 --- a/src/submodules/MassMatrix/src/MM_2a.inc +++ b/src/submodules/MassMatrix/src/MM_2a.inc @@ -37,7 +37,7 @@ PURE SUBROUTINE MM_2a(ans, test, trial, rho, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) !! diff --git a/src/submodules/MassMatrix/src/MM_2b.inc b/src/submodules/MassMatrix/src/MM_2b.inc index 3cbcb268e..a8532fe26 100644 --- a/src/submodules/MassMatrix/src/MM_2b.inc +++ b/src/submodules/MassMatrix/src/MM_2b.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE MM_2b(ans, test, trial, rho, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) !! diff --git a/src/submodules/MassMatrix/src/MM_2c.inc b/src/submodules/MassMatrix/src/MM_2c.inc index edc9450fa..a0631a864 100644 --- a/src/submodules/MassMatrix/src/MM_2c.inc +++ b/src/submodules/MassMatrix/src/MM_2c.inc @@ -37,7 +37,7 @@ PURE SUBROUTINE MM_2c(ans, test, trial, rho, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + 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)) diff --git a/src/submodules/MassMatrix/src/MM_2d.inc b/src/submodules/MassMatrix/src/MM_2d.inc index 00474ec01..11d395eed 100644 --- a/src/submodules/MassMatrix/src/MM_2d.inc +++ b/src/submodules/MassMatrix/src/MM_2d.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE MM_2d(ans, test, trial, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + 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)) diff --git a/src/submodules/MassMatrix/src/MM_3.inc b/src/submodules/MassMatrix/src/MM_3.inc index b72f07d7f..071263c47 100644 --- a/src/submodules/MassMatrix/src/MM_3.inc +++ b/src/submodules/MassMatrix/src/MM_3.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE MM_3(ans, test, trial, rho, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL getInterpolation(obj=trial, ans=kbar, val=rho) CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & & SIZE(kbar, 1), SIZE(kbar, 2)) !! diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 009ca1ada..0ba2e0420 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -40,7 +40,7 @@ PURE SUBROUTINE MM_2a(ans, test, trial, rho) INTEGER(I4B) :: ii, ips ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + 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 @@ -77,7 +77,7 @@ PURE SUBROUTINE MM_2b(ans, test, trial, rho) INTEGER(I4B) :: ii, ips ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + 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 @@ -113,7 +113,7 @@ PURE SUBROUTINE MM_2c(ans, test, trial, rho) INTEGER(I4B) :: ips, ii ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + 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)) @@ -152,7 +152,7 @@ PURE SUBROUTINE MM_2d(ans, test, trial, rho) INTEGER(I4B) :: ips, ii, jj ! main - CALL GetInterpolation(obj=trial, interpol=vbar, val=rho) + 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)) @@ -236,7 +236,7 @@ END SUBROUTINE MM_2d ! main CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) -CALL GetInterpolation(obj=trial, interpol=realval, val=rho) +CALL GetInterpolation(obj=trial, ans=realval, val=rho) realval = trial%js * trial%ws * trial%thickness * realval DO ips = 1, SIZE(realval) @@ -260,8 +260,7 @@ END SUBROUTINE MM_2d nrow = test%nns ncol = trial%nns realval = 0.0_DFP -CALL GetInterpolation_(obj=trial, interpol=realval, & - val=rho, tsize=ii) +CALL GetInterpolation_(obj=trial, ans=realval, val=rho, tsize=ii) realval = trial%js * trial%ws * trial%thickness * realval DO ips = 1, SIZE(realval) @@ -316,7 +315,7 @@ END SUBROUTINE MM_2d INTEGER(I4B) :: ii, jj, ips ! main -CALL GetInterpolation(obj=trial, interpol=kbar, val=rho) +CALL GetInterpolation(obj=trial, ans=kbar, val=rho) CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & & SIZE(kbar, 1), SIZE(kbar, 2)) @@ -360,9 +359,9 @@ 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))) diff --git a/src/submodules/STConvectiveMatrix/src/STCM_10.inc b/src/submodules/STConvectiveMatrix/src/STCM_10.inc index 7f4492b77..3cf8f47db 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_10.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_10.inc @@ -45,7 +45,7 @@ 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) !! @@ -100,7 +100,7 @@ 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) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc index 1b76e4d6d..20e92d24e 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc @@ -43,7 +43,7 @@ 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 !! @@ -144,7 +144,7 @@ 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, & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_12.inc b/src/submodules/STConvectiveMatrix/src/STCM_12.inc index ffb27a1d8..0c46e634e 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_12.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_12.inc @@ -46,7 +46,7 @@ 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) !! @@ -99,7 +99,7 @@ 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) !! diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc index dfe461067..c17547546 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_13.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_13.inc @@ -40,7 +40,7 @@ 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), & @@ -104,7 +104,7 @@ 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), & @@ -168,7 +168,7 @@ 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), & @@ -232,7 +232,7 @@ 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), & @@ -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 8e7a0fae7..81d864d18 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_14.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_14.inc @@ -40,7 +40,7 @@ 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), & @@ -104,7 +104,7 @@ 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), & @@ -168,7 +168,7 @@ 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), & @@ -232,7 +232,7 @@ 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), & @@ -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 07bc3e9c8..7ed27ea92 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_15.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_15.inc @@ -44,8 +44,8 @@ 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), & @@ -113,8 +113,8 @@ 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), & @@ -182,8 +182,8 @@ 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), & @@ -251,8 +251,8 @@ 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), & @@ -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 42d6fde39..6b77ac369 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_16.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_16.inc @@ -44,8 +44,8 @@ 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), & @@ -113,8 +113,8 @@ 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), & @@ -182,8 +182,8 @@ 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), & @@ -251,8 +251,8 @@ 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), & @@ -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 091bf4901..4a38201a5 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc @@ -46,9 +46,9 @@ 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), & @@ -120,9 +120,9 @@ 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), & @@ -194,9 +194,9 @@ 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), & @@ -268,8 +268,8 @@ 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), & @@ -308,4 +308,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 dbaf727b9..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 @@ -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 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 0e0019c5c..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 @@ -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 diff --git a/src/submodules/STConvectiveMatrix/src/STCM_9.inc b/src/submodules/STConvectiveMatrix/src/STCM_9.inc index 301ffc2e9..25456541a 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_9.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_9.inc @@ -42,7 +42,7 @@ 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) !! @@ -94,7 +94,7 @@ 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) !! 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 de726de3e..ee949659d 100644 --- a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 @@ -51,7 +51,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)%nsd !! @@ -117,7 +117,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)%nsd !! @@ -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, & @@ -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, & @@ -351,8 +351,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)%nsd !! @@ -421,8 +421,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)%nsd !! @@ -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, & @@ -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, & @@ -706,7 +706,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! !! 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)) @@ -791,7 +791,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)) !! -CALL getInterpolation(obj=trial, interpol=kbar, val=k) +CALL getInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%nsd !! @@ -843,8 +843,8 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! !! 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)) @@ -897,7 +897,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! 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) !! @@ -943,8 +943,8 @@ END SUBROUTINE MakeDiagonalCopiesIJab 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)%nsd !! @@ -1096,8 +1096,8 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! 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)%nsd !! DO ipt = 1, SIZE(trial) diff --git a/src/submodules/STForceVector/src/STFV_10.inc b/src/submodules/STForceVector/src/STFV_10.inc index 4d1d43572..c6cc71efc 100644 --- a/src/submodules/STForceVector/src/STFV_10.inc +++ b/src/submodules/STForceVector/src/STFV_10.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_10(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_11.inc b/src/submodules/STForceVector/src/STFV_11.inc index a8dd461fd..0709e4e88 100644 --- a/src/submodules/STForceVector/src/STFV_11.inc +++ b/src/submodules/STForceVector/src/STFV_11.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_11(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_12.inc b/src/submodules/STForceVector/src/STFV_12.inc index 30f70caa6..61a30dd9b 100644 --- a/src/submodules/STForceVector/src/STFV_12.inc +++ b/src/submodules/STForceVector/src/STFV_12.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_12(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_13.inc b/src/submodules/STForceVector/src/STFV_13.inc index 46c60fca7..dd18c1d90 100644 --- a/src/submodules/STForceVector/src/STFV_13.inc +++ b/src/submodules/STForceVector/src/STFV_13.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_13(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_14.inc b/src/submodules/STForceVector/src/STFV_14.inc index 2a15e9e59..7264036ac 100644 --- a/src/submodules/STForceVector/src/STFV_14.inc +++ b/src/submodules/STForceVector/src/STFV_14.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_14(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_16.inc b/src/submodules/STForceVector/src/STFV_16.inc index 1e7d142a4..b9884f947 100644 --- a/src/submodules/STForceVector/src/STFV_16.inc +++ b/src/submodules/STForceVector/src/STFV_16.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_16(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_17.inc b/src/submodules/STForceVector/src/STFV_17.inc index 4bca8d65d..d3ec302bb 100644 --- a/src/submodules/STForceVector/src/STFV_17.inc +++ b/src/submodules/STForceVector/src/STFV_17.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_17(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_18.inc b/src/submodules/STForceVector/src/STFV_18.inc index 1e6718d30..407a1c8a5 100644 --- a/src/submodules/STForceVector/src/STFV_18.inc +++ b/src/submodules/STForceVector/src/STFV_18.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_18(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_19.inc b/src/submodules/STForceVector/src/STFV_19.inc index a25da34d2..bf776e476 100644 --- a/src/submodules/STForceVector/src/STFV_19.inc +++ b/src/submodules/STForceVector/src/STFV_19.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_19(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_2.inc b/src/submodules/STForceVector/src/STFV_2.inc index 324e24d1b..5a162d800 100644 --- a/src/submodules/STForceVector/src/STFV_2.inc +++ b/src/submodules/STForceVector/src/STFV_2.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_2(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_20.inc b/src/submodules/STForceVector/src/STFV_20.inc index 9808f017c..8aad09601 100644 --- a/src/submodules/STForceVector/src/STFV_20.inc +++ b/src/submodules/STForceVector/src/STFV_20.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_20(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_21.inc b/src/submodules/STForceVector/src/STFV_21.inc index 23b796789..053f0f79f 100644 --- a/src/submodules/STForceVector/src/STFV_21.inc +++ b/src/submodules/STForceVector/src/STFV_21.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_21(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_3.inc b/src/submodules/STForceVector/src/STFV_3.inc index 76603c036..de9717b3e 100644 --- a/src/submodules/STForceVector/src/STFV_3.inc +++ b/src/submodules/STForceVector/src/STFV_3.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_3(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_4.inc b/src/submodules/STForceVector/src/STFV_4.inc index 9035f097f..d87c2e60a 100644 --- a/src/submodules/STForceVector/src/STFV_4.inc +++ b/src/submodules/STForceVector/src/STFV_4.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_4(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_5.inc b/src/submodules/STForceVector/src/STFV_5.inc index 297e0089e..886663ef3 100644 --- a/src/submodules/STForceVector/src/STFV_5.inc +++ b/src/submodules/STForceVector/src/STFV_5.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_5(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_6.inc b/src/submodules/STForceVector/src/STFV_6.inc index 9d1f365b2..91a8fd281 100644 --- a/src/submodules/STForceVector/src/STFV_6.inc +++ b/src/submodules/STForceVector/src/STFV_6.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_6(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_7.inc b/src/submodules/STForceVector/src/STFV_7.inc index ed62cd905..608563190 100644 --- a/src/submodules/STForceVector/src/STFV_7.inc +++ b/src/submodules/STForceVector/src/STFV_7.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STFV_7(ans, test, term1, c1, c1rank, c2, c2rank) !! !! main !! - CALL getInterpolation(obj=test, interpol=c1bar, val=c1) - CALL getInterpolation(obj=test, interpol=c2bar, val=c2) + CALL getInterpolation(obj=test, ans=c1bar, val=c1) + CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STFV_9.inc b/src/submodules/STForceVector/src/STFV_9.inc index 2ec1de665..80b1620c8 100644 --- a/src/submodules/STForceVector/src/STFV_9.inc +++ b/src/submodules/STForceVector/src/STFV_9.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE STFV_9(ans, test, term1, c, crank) !! !! main !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) + CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index aced7d296..07fe9fb90 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -89,7 +89,7 @@ !! !! main !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) +CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & @@ -125,7 +125,7 @@ !! !! main !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) +CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & @@ -164,7 +164,7 @@ !! !! main !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) +CALL getInterpolation(obj=test, ans=cbar, val=c) !! CALL reallocate( & & ans, & @@ -204,8 +204,8 @@ !! !! main !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c1bar, val=c1) +CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & @@ -243,8 +243,8 @@ !! !! main !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c1bar, val=c1) +CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & @@ -285,8 +285,8 @@ !! !! main !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c1bar, val=c1) +CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & @@ -626,7 +626,7 @@ !! main !! CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & @@ -662,7 +662,7 @@ !! main !! CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & @@ -704,7 +704,7 @@ !! main !! CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c2bar, val=c2) !! CALL reallocate( & & ans, & @@ -745,8 +745,8 @@ !! 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 getInterpolation(obj=test, ans=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c3bar, val=c3) !! CALL reallocate( & & ans, & @@ -787,8 +787,8 @@ !! 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 getInterpolation(obj=test, ans=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c3bar, val=c3) !! CALL reallocate( & & ans, & @@ -830,8 +830,8 @@ !! 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 getInterpolation(obj=test, ans=c2bar, val=c2) +CALL getInterpolation(obj=test, ans=c3bar, val=c3) !! CALL reallocate( & & ans, & 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 65c2c2283..e61619ce8 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) @@ -106,7 +106,7 @@ ncol = nns2 * nsd ans(1:nrow, 1:ncol) = 0.0 -CALL GetInterpolation_(obj=test, interpol=CBar, val=Cijkl, & +CALL GetInterpolation_(obj=test, ans=CBar, val=Cijkl, & dim1=ii, dim2=jj, dim3=kk) SELECT CASE (nsd) @@ -179,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 @@ -256,8 +256,8 @@ ncol = nns2 * nsd ans(1:nrow, 1:ncol) = zero -CALL GetInterpolation_(obj=test, interpol=lambdaBar, val=lambda0, tsize=ii) -CALL GetInterpolation_(obj=test, interpol=muBar, val=mu, tsize=ii) +CALL GetInterpolation_(obj=test, ans=lambdaBar, val=lambda0, tsize=ii) +CALL GetInterpolation_(obj=test, ans=muBar, val=mu, tsize=ii) DO ips = 1, nips From 205e9a803e38c0a3a610b0b99777d91384cf9c99 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 30 Aug 2025 21:54:51 +0900 Subject: [PATCH 018/184] Adding GetInterpolation for Vector --- .../ElemshapeData_VectorInterpolMethods.F90 | 201 +++++++++---- ...hapeData_VectorInterpolMethods@Methods.F90 | 266 +++++++++++------- 2 files changed, 313 insertions(+), 154 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 index e2926f25a..2065bd473 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 @@ -29,7 +29,7 @@ MODULE ElemshapeData_VectorInterpolMethods PUBLIC :: STInterpolation !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -44,35 +44,54 @@ MODULE ElemshapeData_VectorInterpolMethods ! $$u_{i}=u_{iI}N^{I}$$ INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, ans, val) + 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 vector_getInterpolation_1 + END SUBROUTINE GetInterpolation1 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation_@Methods !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-03 +!> 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 vector_getInterpolation1_(obj,ans, val, & - nrow, ncol) + 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 - END SUBROUTINE vector_getInterpolation1_ + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_1a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -87,17 +106,17 @@ END SUBROUTINE vector_getInterpolation1_ ! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, ans, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj + 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 vector_getInterpolation_2 + END SUBROUTINE GetInterpolation2 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation_@Methods !---------------------------------------------------------------------------- !> author: Shion Shimizu @@ -105,17 +124,36 @@ END SUBROUTINE vector_getInterpolation_2 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, ans, val, & - nrow, ncol) - CLASS(ElemshapeData_), INTENT(IN) :: obj + 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 vector_getInterpolation2_ + END SUBROUTINE GetInterpolation_2 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! 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. @@ -130,35 +168,54 @@ END SUBROUTINE vector_getInterpolation2_ ! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, ans, val) + MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE ::ans(:, :, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :) !! REAL(DFP), INTENT(IN) :: val(:, :, :) !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE vector_getInterpolation_3 + END SUBROUTINE GetInterpolation3 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation_@Methods !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-03 +!> 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 vector_getInterpolation3_(obj,ans, val, & - dim1, dim2, dim3) + 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(INOUT) :: ans(:, :, :) REAL(DFP), INTENT(IN) :: val(:, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE vector_getInterpolation3_ + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_3a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -178,35 +235,54 @@ END SUBROUTINE vector_getInterpolation3_ ! NOTE This routine calls [[Interpolation]] function from the same module. ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_4(obj,ans, val) + 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 vector_getInterpolation_4 + END SUBROUTINE GetInterpolation4 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation_@Methods !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-03 +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 ! summary: get interpolation of vector without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, ans, val, & - nrow, ncol) + 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 vector_getInterpolation4_ + END SUBROUTINE GetInterpolation_4 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! 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) + 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 + END SUBROUTINE GetInterpolation_4a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -226,31 +302,50 @@ END SUBROUTINE vector_getInterpolation4_ ! NOTE This routine calls [[Interpolation]] function from the same module. ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, ans, val) + 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 vector_getInterpolation_5 + END SUBROUTINE GetInterpolation5 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation_@Methods !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-03 +!> 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 vector_getInterpolation5_(obj, ans, val, & - dim1, dim2, dim3) + 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 - END SUBROUTINE vector_getInterpolation5_ + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_5a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- @@ -262,15 +357,15 @@ END SUBROUTINE vector_getInterpolation5_ ! summary: This function returns the interpolation of vector INTERFACE - MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(ans) + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:, :) REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION vector_interpolation_1 + END FUNCTION Interpolation1 END INTERFACE INTERFACE Interpolation - MODULE PROCEDURE vector_interpolation_1 + MODULE PROCEDURE Interpolation1 END INTERFACE Interpolation !---------------------------------------------------------------------------- @@ -286,17 +381,17 @@ END FUNCTION vector_interpolation_1 ! values. ! $$u=u^{a}_{I}N^{I}T_{a}$$ - MODULE PURE FUNCTION vector_stinterpolation_1(obj, val) RESULT(ans) + 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 vector_stinterpolation_1 + END FUNCTION STInterpolation1 END INTERFACE INTERFACE STInterpolation - MODULE PROCEDURE vector_stinterpolation_1 + MODULE PROCEDURE STInterpolation1 END INTERFACE STInterpolation END MODULE ElemshapeData_VectorInterpolMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 index cbe0be749..d27a770b2 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 @@ -17,133 +17,189 @@ SUBMODULE(ElemshapeData_VectorInterpolMethods) Methods USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: FEVariableSize => Size + IMPLICIT NONE CONTAINS !--------------------------------------------------------------------------- -! getinterpolation +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE vector_getinterpolation_1 -ans = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation_1 +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 vector_getinterpolation1_ +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 = SIZE(obj%N, 2) -ans(1:nrow, 1:ncol) = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation1_ +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 !---------------------------------------------------------------------------- -! getSTinterpolation +! GetInterpolation_ !---------------------------------------------------------------------------- -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 +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 vector_getinterpolation2_ -! SELECT TYPE (obj) -! TYPE IS (STElemShapeData_) -! nrow = SIZE(val, 1) -! ncol = SIZE(obj%N, 2) -! interpol(1:nrow, 1:ncol) = MATMUL(MATMUL(val, obj%T), obj%N) -! END SELECT -END PROCEDURE vector_getinterpolation2_ +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 !---------------------------------------------------------------------------- -! getSTinterpolation +! GetInterpolation_ !---------------------------------------------------------------------------- -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 +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 vector_getinterpolation3_ -! INTEGER(I4B) :: ipt -! -! dim1 = SIZE(val, 1) -! dim2 = SIZE(obj(1)%N, 2) -! dim3 = SIZE(obj) -! DO ipt = 1, dim3 -! interpol(1:dim1, 1:dim2, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), & -! obj(ipt)%N) -! END DO -END PROCEDURE vector_getinterpolation3_ +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 +! 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_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 vector_getinterpolation4_ +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) :: ii ! ! SELECT CASE (val%vartype) @@ -177,13 +233,13 @@ ! nrow=nrow, ncol=ncol) ! END SELECT ! END SELECT -END PROCEDURE vector_getinterpolation4_ +END PROCEDURE GetInterpolation_4a !---------------------------------------------------------------------------- -! getSTinterpolation +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE vector_getinterpolation_5 +MODULE PROCEDURE GetInterpolation5 ! REAL(DFP), ALLOCATABLE :: m1(:) ! INTEGER(I4B) :: ii, jj ! INTEGER(I4B), ALLOCATABLE :: s(:) @@ -249,13 +305,13 @@ ! !! ! END SELECT ! !! -END PROCEDURE vector_getinterpolation_5 +END PROCEDURE GetInterpolation5 !---------------------------------------------------------------------------- -! +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE vector_getinterpolation5_ +MODULE PROCEDURE GetInterpolation_5 ! INTEGER(I4B) :: ii, jj ! ! dim1 = SIZE(val, 1) @@ -304,14 +360,22 @@ ! val=interpol, dim1=dim1, dim2=dim2, dim3=dim3) ! END IF ! END SELECT -END PROCEDURE vector_getinterpolation5_ +END PROCEDURE GetInterpolation_5 !---------------------------------------------------------------------------- -! interpolationOfVector +! Interpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE vector_interpolation_1 +MODULE PROCEDURE Interpolation1 ! interpol = MATMUL(val, obj%N) -END PROCEDURE vector_interpolation_1 +END PROCEDURE Interpolation1 + +!---------------------------------------------------------------------------- +! STInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STInterpolation1 + +END PROCEDURE STInterpolation1 END SUBMODULE Methods From 7499ed83c2742d356cff936ccfc3f2541a324d96 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 31 Aug 2025 12:26:43 +0900 Subject: [PATCH 019/184] Updating FEVariable Adding vector Interpolation --- .../FEVariable/src/FEVariable_Method.F90 | 119 +++++++++++- ...able_Method@VectorInterpolationMethods.F90 | 174 ++++++++++++++++++ 2 files changed, 292 insertions(+), 1 deletion(-) create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index fb2762199..13d0750c0 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -1977,9 +1977,126 @@ MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_(obj, rank, & !! 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 + INTEGER(I4B), INTENT(IN) :: timeIndx !! time index is used when varType is spaceTime and defined on Quad END SUBROUTINE ScalarSpaceTimeGetInterpolation_ 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_(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_ +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_(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_ +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_(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_ +END INTERFACE GetInterpolation_ + END MODULE FEVariable_Method diff --git a/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 new file mode 100644 index 000000000..56e1be7fe --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 @@ -0,0 +1,174 @@ +! 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_Method) VectorInterpolationMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorConstantGetInterpolation_ +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_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal_(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 MasterGetInterpolationFromNodal_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature_(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 MasterGetInterpolationFromQuadrature_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorSpaceGetInterpolation_ +INTEGER(I4B) :: ips, valEnd + +nrow = obj%s(1) +ncol = nips +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +SELECT CASE (obj%varType) +CASE (TypeFEVariableOpt%nodal) + !! Nodal Vector Space + !! Convert nodal values to quadrature values by using N(:,:) + !! make sure nns .LE. obj%len + + CALL MasterGetInterpolationFromNodal_(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 MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & + nsd=nrow, nips=nips, & + val=obj%val, valStart=0, & + valEnd=valEnd) + +END SELECT + +END PROCEDURE VectorSpaceGetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorSpaceTimeGetInterpolation_ +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%varType) +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 MasterGetInterpolationFromNodal_(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 MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & + nsd=nrow, nips=nips, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd) + +END SELECT + +END PROCEDURE VectorSpaceTimeGetInterpolation_ + +END SUBMODULE VectorInterpolationMethods From a2a089986fbc2760590fb75572fc8323c5569081 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 31 Aug 2025 12:29:09 +0900 Subject: [PATCH 020/184] Updating FEVariable minor changes in VectorSpaceGetInterpolation_ --- .../src/FEVariable_Method@VectorInterpolationMethods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 index 56e1be7fe..4c18de3e4 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 @@ -96,7 +96,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature_ !---------------------------------------------------------------------------- MODULE PROCEDURE VectorSpaceGetInterpolation_ -INTEGER(I4B) :: ips, valEnd +INTEGER(I4B) :: valEnd nrow = obj%s(1) ncol = nips From dd03126a568b19e8882535708de4e55209cb3315 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 31 Aug 2025 12:51:51 +0900 Subject: [PATCH 021/184] updates in FEVariable updates in cmake of FEVariable submodules --- src/submodules/FEVariable/CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index 988d1dc58..9dc2f68b1 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -32,4 +32,5 @@ target_sources( ${src_path}/FEVariable_Method@Norm2Methods.F90 ${src_path}/FEVariable_Method@EqualMethods.F90 ${src_path}/FEVariable_Method@MeanMethods.F90 - ${src_path}/FEVariable_Method@ScalarInterpolationMethods.F90) + ${src_path}/FEVariable_Method@ScalarInterpolationMethods.F90 + ${src_path}/FEVariable_Method@VectorInterpolationMethods.F90) From 5bc75622e38406bd02d374847c581960d4d4031e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 31 Aug 2025 15:56:08 +0900 Subject: [PATCH 022/184] Update ElemShapeData_Method adding interpol methods for vector and matrix --- .../ElemshapeData_MatrixInterpolMethods.F90 | 223 +++++++-- .../ElemshapeData_VectorInterpolMethods.F90 | 3 +- ...hapeData_MatrixInterpolMethods@Methods.F90 | 467 ++++++++++-------- ...hapeData_ScalarInterpolMethods@Methods.F90 | 14 +- ...hapeData_VectorInterpolMethods@Methods.F90 | 231 ++++----- 5 files changed, 519 insertions(+), 419 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 index 8d166e754..936ae9780 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 @@ -29,7 +29,7 @@ MODULE ElemshapeData_MatrixInterpolMethods PUBLIC :: STInterpolation !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -37,17 +37,17 @@ MODULE ElemshapeData_MatrixInterpolMethods ! summary: This subroutine performs interpolation of matrix INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, ans, val) + 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 matrix_getInterpolation_1 + END SUBROUTINE GetInterpolation1 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation_@Methods !---------------------------------------------------------------------------- !> author: Shion Shimizu @@ -55,17 +55,38 @@ END SUBROUTINE matrix_getInterpolation_1 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, ans, val, & - dim1, dim2, dim3) + 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 matrix_getInterpolation1_ + END SUBROUTINE GetInterpolation_1 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! 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. @@ -78,16 +99,16 @@ END SUBROUTINE matrix_getInterpolation1_ ! nodal values INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, ans, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj + 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 matrix_getInterpolation_2 + END SUBROUTINE GetInterpolation2 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Shion Shimizu @@ -95,17 +116,38 @@ END SUBROUTINE matrix_getInterpolation_2 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, ans, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj + 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 matrix_getInterpolation2_ + END SUBROUTINE GetInterpolation_2 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! 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. @@ -118,17 +160,73 @@ END SUBROUTINE matrix_getInterpolation2_ ! nodal values INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, ans, val) + 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 matrix_getInterpolation_3 + END SUBROUTINE GetInterpolation3 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! 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. @@ -136,17 +234,17 @@ END SUBROUTINE matrix_getInterpolation_3 ! summary: This subroutine performs interpolation of matrix FEVariable ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, ans, val) + 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 matrix_getInterpolation_4 + END SUBROUTINE GetInterpolation4 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Shion Shimizu @@ -154,31 +252,71 @@ END SUBROUTINE matrix_getInterpolation_4 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, ans, val, & - dim1, dim2, dim3) + 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 matrix_getInterpolation4_ + END SUBROUTINE GetInterpolation_4 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-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 !---------------------------------------------------------------------------- INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, ans, val) + 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 matrix_getInterpolation_5 + 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 @@ -186,17 +324,20 @@ END SUBROUTINE matrix_getInterpolation_5 ! summary: get interpolation of matrix without allocation INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, ans, val, & - dim1, dim2, dim3, dim4) + 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 - END SUBROUTINE matrix_getInterpolation5_ + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_5a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! Interpolation@InterpolMethods +! Interpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -204,19 +345,19 @@ END SUBROUTINE matrix_getInterpolation5_ ! summary: This function returns the interpolation of matrix INTERFACE - MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(ans) + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION matrix_interpolation_1 + END FUNCTION Interpolation1 END INTERFACE INTERFACE Interpolation - MODULE PROCEDURE matrix_interpolation_1 + MODULE PROCEDURE Interpolation1 END INTERFACE Interpolation !---------------------------------------------------------------------------- -! STInterpolation@InterpolMethods +! STInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -231,17 +372,17 @@ END FUNCTION matrix_interpolation_1 INTERFACE - MODULE PURE FUNCTION matrix_stinterpolation_1(obj, val) RESULT(ans) + 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 matrix_stinterpolation_1 + END FUNCTION STInterpolation1 END INTERFACE INTERFACE STInterpolation - MODULE PROCEDURE matrix_stinterpolation_1 + MODULE PROCEDURE STInterpolation1 END INTERFACE STInterpolation END MODULE ElemshapeData_MatrixInterpolMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 index 2065bd473..b3dd75df5 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 @@ -271,13 +271,14 @@ END SUBROUTINE GetInterpolation_4 INTERFACE GetInterpolation_ MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, nrow, ncol, & - scale, addContribution) + 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_ diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 index 518a043fc..09f006724 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 @@ -17,6 +17,8 @@ SUBMODULE(ElemshapeData_MatrixInterpolMethods) Methods USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: FEVariableSize => Size + IMPLICIT NONE CONTAINS @@ -24,278 +26,309 @@ ! getinterpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE matrix_getinterpolation_1 -! interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_getinterpolation_1 +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 matrix_getinterpolation1_ -! dim1 = SIZE(val, 1) -! dim2 = SIZE(val, 2) -! dim3 = SIZE(obj%N, 2) -! interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(val, obj%N) -END PROCEDURE matrix_getinterpolation1_ +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 matrix_getinterpolation_2 -! SELECT TYPE (obj) -! TYPE IS (STElemShapeData_) -! interpol = MATMUL(MATMUL(val, obj%T), obj%N) -! END SELECT -END PROCEDURE matrix_getinterpolation_2 +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 matrix_getinterpolation2_ -! SELECT TYPE (obj) -! TYPE IS (STElemShapeData_) -! dim1 = SIZE(val, 1) -! dim2 = SIZE(val, 2) -! dim3 = SIZE(obj%N, 2) -! interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(MATMUL(val, obj%T), obj%N) -! END SELECT -END PROCEDURE matrix_getinterpolation2_ +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 matrix_getinterpolation_3 -!! TODO -END PROCEDURE matrix_getinterpolation_3 +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 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 +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 matrix_getinterpolation4_ -! INTEGER(I4B) :: ii +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 (Constant) -! dim3 = SIZE(obj%N, 2) -! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & -! vartype=TypeFEVariableConstant, & -! val=interpol(:, :, 1), nrow=dim1, ncol=dim2) -! DO ii = 2, dim3 -! interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) -! END DO -! CASE (Space) -! IF (val%DefineOn .EQ. Nodal) THEN -! CALL GetInterpolation_(obj=obj, & -! val=Get(val, TypeFEVariableMatrix, & -! TypeFEVariableSpace), & -! ans=interpol, & -! dim1=dim1, dim2=dim2, dim3=dim3) -! ELSE -! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & -! vartype=TypeFEVariableSpace, val=interpol, & -! dim1=dim1, dim2=dim2, dim3=dim3) -! END IF -! CASE (SpaceTime) -! SELECT TYPE (obj) -! TYPE IS (STElemShapeData_) -! IF (val%DefineOn .EQ. Nodal) THEN -! CALL GetInterpolation_(obj=obj, & -! val=Get(val, TypeFEVariableMatrix, & -! TypeFEVariableSpaceTime), & -! ans=interpol, & -! dim1=dim1, dim2=dim2, dim3=dim3) -! END IF +! 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 matrix_getinterpolation4_ +END PROCEDURE GetInterpolation_4a !---------------------------------------------------------------------------- ! getinterpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE matrix_getinterpolation_5 -! 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 +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 matrix_getinterpolation5_ -! INTEGER(I4B) :: ii, jj -! dim1 = SIZE(val, 1) -! dim2 = SIZE(val, 2) -! dim3 = SIZE(obj(1)%N, 2) -! dim4 = SIZE(obj) -! -! SELECT CASE (val%vartype) -! CASE (Constant) -! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & -! vartype=TypeFEVariableConstant, val=interpol(:, :, 1, 1), & -! nrow=dim1, ncol=dim2) -! DO jj = 1, dim3 -! DO ii = 1, dim4 -! IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE -! interpol(1:dim1, 1:dim2, ii, jj) = interpol(1:dim1, 1:dim2, 1, 1) -! END DO -! END DO -! CASE (Space) -! IF (val%DefineOn .EQ. Nodal) THEN -! DO ii = 1, dim4 -! CALL GetInterpolation_(obj=obj(ii), & -! val=Get(val, TypeFEVariableMatrix, & -! TypeFEVariableSpace), & -! ans=interpol(:, :, :, ii), & -! dim1=dim1, dim2=dim2, dim3=dim3) -! END DO -! ELSE -! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & -! vartype=TypeFEVariableSpace, val=interpol(:, :, :, 1), & -! dim1=dim1, dim2=dim2, dim3=dim3) -! DO ii = 2, dim4 -! interpol(1:dim1, 1:dim2, 1:dim3, ii) = & -! interpol(1:dim1, 1:dim2, 1:dim3, 1) -! END DO -! END IF -! CASE (SpaceTime) -! IF (val%DefineOn .EQ. Nodal) THEN -! DO ii = 1, dim4 -! CALL GetInterpolation_(obj=obj(ii), & -! val=Get(val, TypeFEVariableMatrix, & -! TypeFEVariableSpaceTime), & -! ans=interpol(:, :, :, ii), & -! dim1=dim1, dim2=dim2, dim3=dim3) -! END DO -! ELSE -! CALL Get_(obj=val, rank=TypeFEVariableMatrix, & -! vartype=TypeFEVariableSpaceTime, val=interpol, & -! dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) -! END IF -! END SELECT -END PROCEDURE matrix_getinterpolation5_ +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 matrix_interpolation_1 +MODULE PROCEDURE Interpolation1 ! interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_interpolation_1 +END PROCEDURE Interpolation1 !---------------------------------------------------------------------------- ! STinterpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE matrix_stinterpolation_1 +MODULE PROCEDURE STInterpolation1 ! interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END PROCEDURE matrix_stinterpolation_1 +END PROCEDURE STInterpolation1 END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 index ed0d117ef..9b698f879 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 @@ -262,12 +262,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Interpolation1 -REAL(DFP), PARAMETER :: one = 1.0_DFP -LOGICAL(LGT), PARAMETER :: no = .FALSE. -INTEGER(I4B) :: tsize -CALL Reallocate(ans, obj%nips) -CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, & - scale=one, addContribution=no) +CALL GetInterpolation(obj=obj, ans=ans, val=val) END PROCEDURE Interpolation1 !---------------------------------------------------------------------------- @@ -275,12 +270,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE STInterpolation1 -REAL(DFP), PARAMETER :: one = 1.0_DFP -LOGICAL(LGT), PARAMETER :: no = .FALSE. -INTEGER(I4B) :: tsize -CALL Reallocate(ans, obj%nips) -CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, & - scale=one, addContribution=no) +CALL GetInterpolation(obj=obj, ans=ans, val=val) END PROCEDURE STInterpolation1 END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 index d27a770b2..7a2a3d5bf 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 @@ -19,6 +19,12 @@ 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 @@ -200,39 +206,42 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_4a -! INTEGER(I4B) :: ii -! -! SELECT CASE (val%vartype) -! CASE (Constant) -! CALL Get_(obj=val, rank=TypeFEVariableVector, & -! vartype=TypeFEVariableConstant, & -! val=interpol(:, 1), tsize=nrow) -! ncol = SIZE(obj%N, 2) -! DO ii = 2, ncol -! interpol(1:nrow, ii) = interpol(1:nrow, 1) -! END DO -! CASE (Space) -! IF (val%DefineOn .EQ. Nodal) THEN -! CALL GetInterpolation_(obj=obj, & -! val=Get(val, TypeFEVariableVector, & -! TypeFEVariableSpace), & -! ans=interpol, & -! nrow=nrow, ncol=ncol) -! ELSE -! CALL Get_(obj=val, rank=TypeFEVariableVector, & -! vartype=TypeFEVariableSpace, & -! val=interpol, nrow=nrow, ncol=ncol) -! END IF -! CASE (SpaceTime) -! SELECT TYPE (obj) -! TYPE IS (STElemShapeData_) -! CALL GetInterpolation_(obj=obj, & -! val=Get(val, TypeFEVariableVector, & -! TypeFEVariableSpaceTime), & -! ans=interpol, & -! nrow=nrow, ncol=ncol) -! END SELECT -! END SELECT +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 !---------------------------------------------------------------------------- @@ -240,71 +249,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation5 -! 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 -! !! +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 !---------------------------------------------------------------------------- @@ -312,62 +268,41 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_5 -! INTEGER(I4B) :: ii, jj -! -! dim1 = SIZE(val, 1) -! dim2 = SIZE(obj(1)%N, 2) -! dim3 = SIZE(obj) -! SELECT CASE (val%vartype) -! CASE (Constant) -! CALL Get_(obj=val, rank=TypeFEVariableVector, & -! vartype=TypeFEVariableConstant, & -! val=interpol(:, 1, 1), tsize=dim1) -! DO jj = 1, dim3 -! DO ii = 1, dim2 -! IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE -! interpol(1:dim1, ii, jj) = interpol(1:dim1, 1, 1) -! END DO -! END DO -! CASE (Space) -! IF (val%DefineOn .EQ. Nodal) THEN -! DO ii = 1, dim3 -! CALL GetInterpolation_(obj=obj(ii), & -! val=Get(val, TypeFEVariableVector, & -! TypeFEVariableSpace), & -! ans=interpol(1:dim1, 1:dim2, ii), & -! nrow=dim1, ncol=dim2) -! END DO -! ELSE -! CALL Get_(obj=val, rank=TypeFEVariableVector, & -! vartype=TypeFEVariableSpace, & -! val=interpol(:, :, 1), nrow=dim1, ncol=dim2) -! DO ii = 2, SIZE(obj) -! interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) -! END DO -! END IF -! CASE (SpaceTime) -! IF (val%DefineOn .EQ. Nodal) THEN -! DO ii = 1, SIZE(obj) -! CALL GetInterpolation_(obj=obj(ii), & -! val=Get(val, TypeFEVariableVector, & -! TypeFEVariableSpaceTime), & -! ans=interpol(1:dim1, 1:dim2, ii), & -! nrow=dim1, ncol=dim2) -! END DO -! ELSE -! CALL Get_(obj=val, rank=TypeFEVariableVector, & -! vartype=TypeFEVariableSpaceTime, & -! val=interpol, dim1=dim1, dim2=dim2, dim3=dim3) -! END IF -! END SELECT +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 -! interpol = MATMUL(val, obj%N) +CALL GetInterpolation(obj=obj, ans=ans, val=val) END PROCEDURE Interpolation1 !---------------------------------------------------------------------------- @@ -375,7 +310,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE STInterpolation1 - +CALL GetInterpolation(obj=obj, ans=ans, val=val) END PROCEDURE STInterpolation1 END SUBMODULE Methods From c9ebcdc7055809c9fe13f89e806d66cef7afba87 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 07:59:05 +0900 Subject: [PATCH 023/184] Updating FEVariable_Method Adding Matrix Interpolation Methods --- .../FEVariable/src/FEVariable_Method.F90 | 118 +++++++++++ ...able_Method@MatrixInterpolationMethods.F90 | 185 ++++++++++++++++++ 2 files changed, 303 insertions(+) create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 13d0750c0..ea818db20 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -2099,4 +2099,122 @@ MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_(obj, rank, & END SUBROUTINE VectorSpaceTimeGetInterpolation_ 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_(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_ +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_(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_ +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_(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_ +END INTERFACE GetInterpolation_ + END MODULE FEVariable_Method diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 new file mode 100644 index 000000000..912b3e31e --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 @@ -0,0 +1,185 @@ +! 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_Method) MatrixInterpolationMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixConstantGetInterpolation_ +INTEGER(I4B) :: ips, jj, istart, iend + +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 + istart = (jj - 1) * dim1 + 1 + iend = jj * dim1 + ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & + + scale * obj%val(istart:iend) + END DO +END DO +END PROCEDURE MatrixConstantGetInterpolation_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal_(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, jj, istart, iend + + DO ips = 1, nips + DO jj = 1, dim2 + istart = (jj - 1) * dim1 + 1 + valStart + iend = jj * dim1 + valStart + ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & + + scale * N(jj, ips) * val(istart:iend) + END DO + END DO + + valEnd = valStart + nns * dim1 * dim2 + +END SUBROUTINE MasterGetInterpolationFromNodal_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature_(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, istart, iend, jj + + DO ips = 1, nips + DO jj = 1, dim2 + istart = (jj - 1) * dim1 + 1 + valStart + iend = jj * dim1 + valStart + ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) + scale * val(istart:iend) + END DO + END DO + + valEnd = valStart + nips * dim1 * dim2 + +END SUBROUTINE MasterGetInterpolationFromQuadrature_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixSpaceGetInterpolation_ +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%varType) +CASE (TypeFEVariableOpt%nodal) + !! Nodal Matrix Space + !! Convert nodal values to quadrature values by using N(:,:) + !! make sure nns .LE. obj%len + + CALL MasterGetInterpolationFromNodal_(ans=ans, scale=scale, N=N, & + nns=nns, nips=nips, val=obj%val, & + dim1=dim1, dim2=dim2, & + valStart=0, valEnd=valEnd) + +CASE (TypeFEVariableOpt%quadrature) + !! No need for interpolation, just returnt the quadrature values + !! make sure nips .LE. obj%len + + CALL MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & + nips=nips, dim1=dim1, & + dim2=dim2, val=obj%val, & + valStart=0, valEnd=valEnd) + +END SELECT +END PROCEDURE MatrixSpaceGetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_ +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%varType) +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 MasterGetInterpolationFromNodal_(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) + !! No need for interpolation, just returnt the quadrature values + !! make sure nips .LE. obj%len + + valStart = nips * dim1 * dim2 * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & + dim1=dim1, dim2=dim2, & + nips=nips, val=obj%val, & + valStart=valStart, valEnd=valEnd) + +END SELECT +END PROCEDURE MatrixSpaceTimeGetInterpolation_ + +END SUBMODULE MatrixInterpolationMethods From caf2c8dd78f4eea13d16f03fc04f70225f3d723a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 07:59:34 +0900 Subject: [PATCH 024/184] Updating FEVariable_Method Adding Cmake for Matrix Interpolation Methods --- src/submodules/FEVariable/CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index 9dc2f68b1..58808e35c 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -33,4 +33,5 @@ target_sources( ${src_path}/FEVariable_Method@EqualMethods.F90 ${src_path}/FEVariable_Method@MeanMethods.F90 ${src_path}/FEVariable_Method@ScalarInterpolationMethods.F90 - ${src_path}/FEVariable_Method@VectorInterpolationMethods.F90) + ${src_path}/FEVariable_Method@VectorInterpolationMethods.F90 + ${src_path}/FEVariable_Method@MatrixInterpolationMethods.F90) From 8be6ada6e3b686aa9269f96c79efd53f4135bedc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 08:51:38 +0900 Subject: [PATCH 025/184] Updating BaseType Adding isInit in FEVariable --- src/modules/BaseType/src/BaseType.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 957e6b552..fc9cfce45 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1098,26 +1098,23 @@ END SUBROUTINE highorder_refelem ! {!pages/FEVariable_.md!} 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) :: 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()) From ead2940cc3b793e5b21ea182f28f74daf20300c1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 08:52:21 +0900 Subject: [PATCH 026/184] Updating FEVariable Adding Master Interpolation methods. Interpolating FEVariable to FEVariable --- .../FEVariable/src/FEVariable_Method.F90 | 29 +++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index ea818db20..fde619260 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -2217,4 +2217,33 @@ MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_(obj, rank, & END SUBROUTINE MatrixSpaceTimeGetInterpolation_ 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_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 + END SUBROUTINE FEVariableGetInterpolation_1 +END INTERFACE GetInterpolation_ + END MODULE FEVariable_Method From d9df1df23fd4b69eef82c42d64952776a9b7c31a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 08:52:45 +0900 Subject: [PATCH 027/184] Updating FEVariable_Method Adding Master inteprolation, fevariable interpolation into fevariable --- ...FEVariable_Method@InterpolationMethods.F90 | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 diff --git a/src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 new file mode 100644 index 000000000..f28dbc637 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 @@ -0,0 +1,31 @@ +! 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_Method) InterpolationMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FEVariableGetInterpolation_1 + +END PROCEDURE FEVariableGetInterpolation_1 + +END SUBMODULE InterpolationMethods From e25f8acbf3c697ce5d0712c4c387e970e6ce824d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 08:52:57 +0900 Subject: [PATCH 028/184] Updating FEVarible_Method updating cmake --- src/submodules/FEVariable/CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index 58808e35c..dbce371d5 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -34,4 +34,5 @@ target_sources( ${src_path}/FEVariable_Method@MeanMethods.F90 ${src_path}/FEVariable_Method@ScalarInterpolationMethods.F90 ${src_path}/FEVariable_Method@VectorInterpolationMethods.F90 - ${src_path}/FEVariable_Method@MatrixInterpolationMethods.F90) + ${src_path}/FEVariable_Method@MatrixInterpolationMethods.F90 + ${src_path}/FEVariable_Method@InterpolationMethods.F90) From 39f678d862d41d6e753f1ee3d1b45b40dd8e4e83 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 09:04:07 +0900 Subject: [PATCH 029/184] Updating FEVariable Incorporting isInit in FEVariable --- .../src/FEVariable_Method@ConstructorMethods.F90 | 8 +++++++- .../FEVariable/src/FEVariable_Method@IOMethods.F90 | 1 + src/submodules/FEVariable/src/include/matrix_constant.F90 | 1 + .../FEVariable/src/include/matrix_constant2.F90 | 1 + src/submodules/FEVariable/src/include/matrix_space.F90 | 1 + src/submodules/FEVariable/src/include/matrix_space2.F90 | 1 + .../FEVariable/src/include/matrix_space_time.F90 | 1 + .../FEVariable/src/include/matrix_space_time2.F90 | 1 + src/submodules/FEVariable/src/include/matrix_time.F90 | 1 + src/submodules/FEVariable/src/include/matrix_time2.F90 | 1 + src/submodules/FEVariable/src/include/scalar_constant.F90 | 1 + src/submodules/FEVariable/src/include/scalar_space.F90 | 1 + .../FEVariable/src/include/scalar_space_time.F90 | 1 + .../FEVariable/src/include/scalar_space_time2.F90 | 2 ++ src/submodules/FEVariable/src/include/scalar_time.F90 | 1 + src/submodules/FEVariable/src/include/vector_constant.F90 | 1 + src/submodules/FEVariable/src/include/vector_space.F90 | 1 + src/submodules/FEVariable/src/include/vector_space2.F90 | 1 + .../FEVariable/src/include/vector_space_time.F90 | 1 + .../FEVariable/src/include/vector_space_time2.F90 | 1 + src/submodules/FEVariable/src/include/vector_time.F90 | 1 + src/submodules/FEVariable/src/include/vector_time2.F90 | 1 + 22 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 index 4cd019838..8c6be5c29 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 @@ -36,6 +36,7 @@ obj%rank = 0 obj%len = 0 obj%capacity = 0 +obj%isInit = .FALSE. END PROCEDURE fevar_Deallocate !---------------------------------------------------------------------------- @@ -443,11 +444,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Copy +LOGICAL(LGT) :: isok + obj1%s = obj2%s 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) @@ -456,7 +460,9 @@ obj1%capacity = CAPACITY_EXPAND_FACTOR * obj1%len CALL Reallocate(obj1%val, obj1%capacity) -obj1%val(1:obj1%len) = obj2%val(1:obj1%len) + +isok = ALLOCATED(obj2%val) +IF (isok) obj1%val(1:obj1%len) = obj2%val(1:obj1%len) END PROCEDURE obj_Copy diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 index 276dd37c0..a23f83724 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 @@ -131,6 +131,7 @@ 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 diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90 index bb2d804b9..af887ec55 100644 --- a/src/submodules/FEVariable/src/include/matrix_constant.F90 +++ b/src/submodules/FEVariable/src/include/matrix_constant.F90 @@ -17,3 +17,4 @@ 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 index 062b751b9..f9eb28649 100644 --- a/src/submodules/FEVariable/src/include/matrix_constant2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90 @@ -8,3 +8,4 @@ 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 index 0cd267920..6ea254890 100644 --- a/src/submodules/FEVariable/src/include/matrix_space.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space.F90 @@ -19,3 +19,4 @@ 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 index d9cd89b84..b82372f7e 100644 --- a/src/submodules/FEVariable/src/include/matrix_space2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space2.F90 @@ -8,3 +8,4 @@ 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 index 3a6463630..9e445c8af 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90 @@ -21,3 +21,4 @@ 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 index 416f4d703..8aed83e31 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 @@ -8,3 +8,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 index a4b831d86..3bdc1544e 100644 --- a/src/submodules/FEVariable/src/include/matrix_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_time.F90 @@ -19,3 +19,4 @@ 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 index aaa1007bb..1b4b4a80e 100644 --- a/src/submodules/FEVariable/src/include/matrix_time2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_time2.F90 @@ -8,3 +8,4 @@ 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 index 628f7a7b6..94597f6a9 100644 --- a/src/submodules/FEVariable/src/include/scalar_constant.F90 +++ b/src/submodules/FEVariable/src/include/scalar_constant.F90 @@ -6,3 +6,4 @@ 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 index c43d15d52..bd0c481a1 100644 --- a/src/submodules/FEVariable/src/include/scalar_space.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space.F90 @@ -6,3 +6,4 @@ 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 index 75ee2a726..ed8d43619 100644 --- a/src/submodules/FEVariable/src/include/scalar_space_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90 @@ -16,3 +16,4 @@ 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 index e85818d99..19ee3e1bd 100644 --- a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 @@ -10,3 +10,5 @@ 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 index 1a7b0d3e3..cf5060ffb 100644 --- a/src/submodules/FEVariable/src/include/scalar_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_time.F90 @@ -6,3 +6,4 @@ 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 index 42125ac15..6c2d602a0 100644 --- a/src/submodules/FEVariable/src/include/vector_constant.F90 +++ b/src/submodules/FEVariable/src/include/vector_constant.F90 @@ -8,3 +8,4 @@ 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 index 2d6a663ef..91f13691b 100644 --- a/src/submodules/FEVariable/src/include/vector_space.F90 +++ b/src/submodules/FEVariable/src/include/vector_space.F90 @@ -16,3 +16,4 @@ 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 index a2e7c5cbf..db7eb132b 100644 --- a/src/submodules/FEVariable/src/include/vector_space2.F90 +++ b/src/submodules/FEVariable/src/include/vector_space2.F90 @@ -8,3 +8,4 @@ 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 index e8ee7a797..b6e15e8a3 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time.F90 @@ -19,3 +19,4 @@ 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 index a671d1408..2083899ec 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90 @@ -8,3 +8,4 @@ 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 index 7cc4a4a7f..e60381c70 100644 --- a/src/submodules/FEVariable/src/include/vector_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_time.F90 @@ -16,3 +16,4 @@ 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 index b3e52b512..3310c0176 100644 --- a/src/submodules/FEVariable/src/include/vector_time2.F90 +++ b/src/submodules/FEVariable/src/include/vector_time2.F90 @@ -8,3 +8,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = TIME +obj%isInit = .TRUE. From 4c448642a855b4d16b5c2fb8ba100ea3765e90e1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 15:17:42 +0900 Subject: [PATCH 030/184] Updating BaseType adding capacityExpandFactor in FEVariableOpt_ --- src/modules/BaseType/src/BaseType.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index fc9cfce45..9e4be8825 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -2004,6 +2004,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: solutionDependent = solutionDependent INTEGER(I4B) :: randomSpace = randomSpace INTEGER(I4B) :: maxRank = MAX_RANK_FEVARIABLE + INTEGER(I4B) :: capacityExpandFactor = 1 END TYPE FEVariableOpt_ TYPE(FEVariableOpt_), PARAMETER :: TypeFEVariableOpt = FEVariableOpt_() From 1c17042d57541a4f7da05e219ee2bc62da9bda46 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 15:18:08 +0900 Subject: [PATCH 031/184] Updating FEVariable adding new design --- src/modules/FEVariable/CMakeLists.txt | 45 +- .../src/FEVariable_AdditionMethod.F90 | 87 + .../src/FEVariable_ConstructorMethod.F90 | 72 + .../src/FEVariable_DivisionMethod.F90 | 87 + .../src/FEVariable_DotProductMethod.F90} | 55 +- .../FEVariable/src/FEVariable_GetMethod.F90 | 661 +++++ .../FEVariable/src/FEVariable_IOMethod.F90 | 52 + .../src/FEVariable_InterpolationMethod.F90 | 417 +++ .../FEVariable/src/FEVariable_MeanMethod.F90 | 99 + .../FEVariable/src/FEVariable_Method.F90 | 2246 +---------------- .../src/FEVariable_MultiplicationMethod.F90 | 91 + .../src/FEVariable_NodalVariableMethod.F90 | 419 +++ .../FEVariable_QuadratureVariableMethod.F90 | 424 ++++ .../src/FEVariable_SubtractionMethod.F90 | 87 + .../FEVariable/src/FEVariable_UnaryMethod.F90 | 138 + src/submodules/FEVariable/CMakeLists.txt | 34 +- ... => FEVariable_AdditionMethod@Methods.F90} | 8 +- ... FEVariable_ConstructorMethod@Methods.F90} | 68 +- ... => FEVariable_DivisionMethod@Methods.F90} | 7 +- .../FEVariable_DotProductMethod@Methods.F90 | 287 +++ ...s.F90 => FEVariable_GetMethod@Methods.F90} | 4 +- ...ds.F90 => FEVariable_IOMethod@Methods.F90} | 6 +- ...ble_InterpolationMethod@MatrixMethods.F90} | 4 +- ...EVariable_InterpolationMethod@Methods.F90} | 4 +- ...ble_InterpolationMethod@ScalarMethods.F90} | 4 +- ...ble_InterpolationMethod@VectorMethods.F90} | 4 +- ....F90 => FEVariable_MeanMethod@Methods.F90} | 7 +- .../src/FEVariable_Method@AbsMethods.F90 | 64 - .../FEVariable_Method@DotProductMethods.F90 | 282 --- .../src/FEVariable_Method@SqrtMethods.F90 | 56 - ...Variable_MultiplicationMethod@Methods.F90} | 8 +- ...FEVariable_NodalVariableMethod@Methods.F90 | 231 ++ ...able_QuadratureVariableMethod@Methods.F90} | 246 +- ... FEVariable_SubtractionMethod@Methods.F90} | 6 +- ...F90 => FEVariable_UnaryMethod@Methods.F90} | 121 +- .../src/include/matrix_constant.F90 | 3 +- .../src/include/matrix_constant2.F90 | 3 +- .../FEVariable/src/include/matrix_space.F90 | 3 +- .../FEVariable/src/include/matrix_space2.F90 | 3 +- .../src/include/matrix_space_time.F90 | 2 +- .../src/include/matrix_space_time2.F90 | 2 +- .../FEVariable/src/include/matrix_time.F90 | 3 +- .../FEVariable/src/include/matrix_time2.F90 | 3 +- .../src/include/scalar_constant.F90 | 3 +- .../FEVariable/src/include/scalar_space.F90 | 3 +- .../src/include/scalar_space_time.F90 | 3 +- .../src/include/scalar_space_time2.F90 | 3 +- .../FEVariable/src/include/scalar_time.F90 | 3 +- .../src/include/vector_constant.F90 | 3 +- .../FEVariable/src/include/vector_space.F90 | 3 +- .../FEVariable/src/include/vector_space2.F90 | 3 +- .../src/include/vector_space_time.F90 | 3 +- .../src/include/vector_space_time2.F90 | 3 +- .../FEVariable/src/include/vector_time.F90 | 3 +- .../FEVariable/src/include/vector_time2.F90 | 3 +- 55 files changed, 3469 insertions(+), 3020 deletions(-) create mode 100644 src/modules/FEVariable/src/FEVariable_AdditionMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_DivisionMethod.F90 rename src/{submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 => modules/FEVariable/src/FEVariable_DotProductMethod.F90} (54%) create mode 100644 src/modules/FEVariable/src/FEVariable_GetMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_IOMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_MeanMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 rename src/submodules/FEVariable/src/{FEVariable_Method@AdditionMethods.F90 => FEVariable_AdditionMethod@Methods.F90} (96%) rename src/submodules/FEVariable/src/{FEVariable_Method@EqualMethods.F90 => FEVariable_ConstructorMethod@Methods.F90} (54%) rename src/submodules/FEVariable/src/{FEVariable_Method@DivisionMethods.F90 => FEVariable_DivisionMethod@Methods.F90} (96%) create mode 100644 src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90 rename src/submodules/FEVariable/src/{FEVariable_Method@GetMethods.F90 => FEVariable_GetMethod@Methods.F90} (99%) rename src/submodules/FEVariable/src/{FEVariable_Method@IOMethods.F90 => FEVariable_IOMethod@Methods.F90} (97%) rename src/submodules/FEVariable/src/{FEVariable_Method@MatrixInterpolationMethods.F90 => FEVariable_InterpolationMethod@MatrixMethods.F90} (98%) rename src/submodules/FEVariable/src/{FEVariable_Method@InterpolationMethods.F90 => FEVariable_InterpolationMethod@Methods.F90} (92%) rename src/submodules/FEVariable/src/{FEVariable_Method@ScalarInterpolationMethods.F90 => FEVariable_InterpolationMethod@ScalarMethods.F90} (97%) rename src/submodules/FEVariable/src/{FEVariable_Method@VectorInterpolationMethods.F90 => FEVariable_InterpolationMethod@VectorMethods.F90} (98%) rename src/submodules/FEVariable/src/{FEVariable_Method@MeanMethods.F90 => FEVariable_MeanMethod@Methods.F90} (97%) delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 rename src/submodules/FEVariable/src/{FEVariable_Method@MultiplicationMethods.F90 => FEVariable_MultiplicationMethod@Methods.F90} (96%) create mode 100644 src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 rename src/submodules/FEVariable/src/{FEVariable_Method@ConstructorMethods.F90 => FEVariable_QuadratureVariableMethod@Methods.F90} (50%) rename src/submodules/FEVariable/src/{FEVariable_Method@SubtractionMethods.F90 => FEVariable_SubtractionMethod@Methods.F90} (96%) rename src/submodules/FEVariable/src/{FEVariable_Method@Norm2Methods.F90 => FEVariable_UnaryMethod@Methods.F90} (51%) diff --git a/src/modules/FEVariable/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt index 2bf970d1a..bbe9030df 100644 --- a/src/modules/FEVariable/CMakeLists.txt +++ b/src/modules/FEVariable/CMakeLists.txt @@ -1,13 +1,36 @@ -# 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 # -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- +# 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}/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_IOMethod.F90 + ${src_path}/FEVariable_MeanMethod.F90) -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FEVariable_Method.F90 -) \ No newline at end of file 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..23c6ba337 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 @@ -0,0 +1,72 @@ +! 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_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: DEALLOCATE +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: Copy + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Deallocates the content of FEVariable + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE fevar_Deallocate(obj) + TYPE(FEVariable_), INTENT(INOUT) :: obj + END SUBROUTINE fevar_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/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 similarity index 54% rename from src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 rename to src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 index 800f72949..6964ed6b4 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 +++ b/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 @@ -13,40 +13,45 @@ ! ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -! -SUBMODULE(FEVariable_Method) PowerMethods -USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & - Scalar, Vector, Matrix, & - Nodal, Quadrature -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime +MODULE FEVariable_DotProductMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE -CONTAINS + +PRIVATE + +PUBLIC :: DOT_PRODUCT !---------------------------------------------------------------------------- -! 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 +!> 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 SUBMODULE PowerMethods +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..2bdf9b117 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_GetMethod.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 + +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 :: OPERATOR(.RANK.) +PUBLIC :: OPERATOR(.vartype.) +PUBLIC :: OPERATOR(.defineon.) +PUBLIC :: isNodalVariable +PUBLIC :: isQuadratureVariable +PUBLIC :: FEVariable_ToChar +PUBLIC :: FEVariable_ToInteger +PUBLIC :: GetLambdaFromYoungsModulus + +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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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..021cefcb6 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 @@ -0,0 +1,417 @@ +! 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_, & + FEVariableScalar_, & + FEVariableVector_, & + 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 scalar, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_(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_ +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_(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_ +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_(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_ +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_(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_ +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_(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_ +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_(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_ +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_(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_ +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_(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_ +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_(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_ +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_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 + END SUBROUTINE FEVariableGetInterpolation_1 +END INTERFACE GetInterpolation_ + +END MODULE FEVariable_InterpolationMethod 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 fde619260..82fc2ee0a 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -15,2235 +15,21 @@ ! along with this program. If not, see MODULE FEVariable_Method -USE BaseType, ONLY: FEVariable_, & - FEVariableScalar_, & - FEVariableVector_, & - FEVariableMatrix_, & - FEVariableConstant_, & - FEVariableSpace_, & - FEVariableTime_, & - FEVariableSpaceTime_, & - TypeFEVariableOpt - -USE GlobalData, ONLY: I4B, DFP, LGT - -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 :: 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 -PUBLIC :: ASSIGNMENT(=) -PUBLIC :: FEVariable_ToChar -PUBLIC :: FEVariable_ToInteger -PUBLIC :: GetInterpolation_ - -INTEGER(I4B), PARAMETER :: CAPACITY_EXPAND_FACTOR = 1 -! capacity = tsize * CAPACITY_EXPAND_FACTOR - -!---------------------------------------------------------------------------- -! 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 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 - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Scalar, Constant - -INTERFACE QuadratureVariable - 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 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 QuadratureVariable - 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 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 QuadratureVariable - 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Scalar, SpaceTime - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Scalar, SpaceTime - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Quadrature_Scalar_SpaceTime2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, Constant - -INTERFACE QuadratureVariable - 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, Space - -INTERFACE QuadratureVariable - - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, Space - -INTERFACE QuadratureVariable - - MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Quadrature_Vector_Space2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, Time - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, Time - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Vector_Time2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Quadrature_Vector_Time2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, SpaceTime - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Vector, SpaceTime - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Vector_SpaceTime2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(3) - END FUNCTION Quadrature_Vector_SpaceTime2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, Constant - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, Constant - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Matrix_Constant2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableConstant_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Quadrature_Matrix_Constant2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, Space - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, Space - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Matrix_Space2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(3) - END FUNCTION Quadrature_Matrix_Space2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, Time - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, Time - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Matrix_Time2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(3) - END FUNCTION Quadrature_Matrix_Time2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, SpaceTime - -INTERFACE QuadratureVariable - MODULE 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 QuadratureVariable - -!---------------------------------------------------------------------------- -! QuadratureVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create quadrature variable, which is Matrix, SpaceTime - -INTERFACE QuadratureVariable - MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(4) - END FUNCTION Quadrature_Matrix_SpaceTime2 -END INTERFACE QuadratureVariable - -!---------------------------------------------------------------------------- -! Deallocate@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Deallocates the content of FEVariable - -INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE fevar_Deallocate(obj) - TYPE(FEVariable_), INTENT(INOUT) :: obj - END SUBROUTINE 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 NodalVariable - 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 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 NodalVariable - - MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - END FUNCTION Nodal_Scalar_Space -END INTERFACE 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 NodalVariable - MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - END FUNCTION Nodal_Scalar_Time -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is scalar, SpaceTime - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is scalar, SpaceTime - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Scalar_SpaceTime2(val, rank, vartype, s) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Nodal_Scalar_SpaceTime2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, Constant - -INTERFACE NodalVariable - 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, Space - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, Space - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Vector_Space2(val, rank, vartype, s) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Nodal_Vector_Space2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, Time - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, Time - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Vector_Time2(val, rank, vartype, s) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Nodal_Vector_Time2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, SpaceTime - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is vector, SpaceTime - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Vector_SpaceTime2(val, rank, vartype, s) & - RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(3) - END FUNCTION Nodal_Vector_SpaceTime2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, Constant - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, Constant - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Matrix_Constant2(val, rank, vartype, s) & - RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableConstant_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(2) - END FUNCTION Nodal_Matrix_Constant2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, Space - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, Space - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Matrix_Space2(val, rank, vartype, s) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(3) - END FUNCTION Nodal_Matrix_Space2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, Time - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, Time - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Matrix_Time2(val, rank, vartype, s) RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(3) - END FUNCTION Nodal_Matrix_Time2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, SpaceTime - -INTERFACE NodalVariable - MODULE 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 NodalVariable - -!---------------------------------------------------------------------------- -! NodalVariable@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-10 -! update: 2021-12-10 -! summary: Create nodal variable, which is Matrix, SpaceTime - -INTERFACE NodalVariable - MODULE PURE FUNCTION Nodal_Matrix_SpaceTime2(val, rank, vartype, s) & - & RESULT(obj) - TYPE(FEVariable_) :: obj - REAL(DFP), INTENT(IN) :: val(:) - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - INTEGER(I4B), INTENT(IN) :: s(4) - END FUNCTION Nodal_Matrix_SpaceTime2 -END INTERFACE NodalVariable - -!---------------------------------------------------------------------------- -! Assignment@ConstructorMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-06-13 -! summary: obj1 = obj2 - -INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE obj_Copy(obj1, obj2) - TYPE(FEVariable_), INTENT(INOUT) :: obj1 - TYPE(FEVariable_), INTENT(IN) :: obj2 - END SUBROUTINE obj_Copy -END INTERFACE - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is Matrix, SpaceTime without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Matrix_SpaceTime_(obj, rank, vartype, val, & - dim1, dim2, dim3, dim4) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 - END SUBROUTINE Matrix_SpaceTime_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Addition@AdditioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! Addition@AdditioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! Addition@AdditioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! Substraction@SubstractioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! Substraction@SubstractioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! Substraction@SubstractioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! 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 - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! Division@DivisionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable - FEVariable - -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 - -!---------------------------------------------------------------------------- -! Division@DivisionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable - Real - -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 - -!---------------------------------------------------------------------------- -! Division@DivisionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = Real - FEVariable - -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 - -!---------------------------------------------------------------------------- -! Power@PowerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! Power@PowerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 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 - -!---------------------------------------------------------------------------- -! 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 - -!---------------------------------------------------------------------------- -! GetInterpolation_@InterpolationMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2025-08-29 -! summary: Get interpolation of scalar, constant - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_(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_ -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_(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_ -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_(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_ -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_(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_ -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_(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_ -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_(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_ -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_(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_ -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_(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_ -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_(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_ -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_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 - END SUBROUTINE FEVariableGetInterpolation_1 -END INTERFACE GetInterpolation_ +USE FEVariable_AdditionMethod +USE FEVariable_DivisionMethod +USE FEVariable_MultiplicationMethod +USE FEVariable_DotProductMethod +USE FEVariable_SubtractionMethod +USE FEVariable_MeanMethod +USE FEVariable_UnaryMethod + +USE FEVariable_ConstructorMethod +USE FEVariable_NodalVariableMethod +USE FEVariable_QuadratureVariableMethod + +USE FEVariable_GetMethod + +USE FEVariable_InterpolationMethod +USE FEVariable_IOMethod 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..26b1d7694 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 @@ -0,0 +1,419 @@ +! 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 NodalVariable + 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 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 NodalVariable + MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Space +END INTERFACE 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 NodalVariable + MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Time +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, SpaceTime + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, SpaceTime + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Scalar_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Scalar_SpaceTime2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Constant + +INTERFACE NodalVariable + 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Space + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Space + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Vector_Space2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Vector_Space2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Time + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Time + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Vector_Time2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Vector_Time2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, SpaceTime + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, SpaceTime + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Vector_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Nodal_Vector_SpaceTime2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Constant + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Constant + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Matrix_Constant2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Matrix_Constant2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Space + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Space + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Matrix_Space2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Nodal_Matrix_Space2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Time + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Time + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Matrix_Time2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Nodal_Matrix_Time2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, SpaceTime + +INTERFACE NodalVariable + MODULE 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 NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, SpaceTime + +INTERFACE NodalVariable + MODULE PURE FUNCTION Nodal_Matrix_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(4) + END FUNCTION Nodal_Matrix_SpaceTime2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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..5c8086557 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 @@ -0,0 +1,424 @@ +! 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 QuadratureVariable + 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 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 QuadratureVariable + 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 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 QuadratureVariable + 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, SpaceTime + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, SpaceTime + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Scalar_SpaceTime2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Constant + +INTERFACE QuadratureVariable + 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Space + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Space + +INTERFACE QuadratureVariable + + MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Vector_Space2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Time + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Time + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Vector_Time2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Vector_Time2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, SpaceTime + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, SpaceTime + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Vector_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Quadrature_Vector_SpaceTime2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Constant + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Constant + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Matrix_Constant2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Matrix_Constant2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Space + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Space + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Matrix_Space2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Quadrature_Matrix_Space2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Time + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Time + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Matrix_Time2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Quadrature_Matrix_Time2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, SpaceTime + +INTERFACE QuadratureVariable + MODULE 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 QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, SpaceTime + +INTERFACE QuadratureVariable + MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(4) + END FUNCTION Quadrature_Matrix_SpaceTime2 +END INTERFACE QuadratureVariable + +END MODULE FEVariable_QuadratureVariableMethod 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..36ac322ed --- /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 :: OPERATOR(.EQ.) +PUBLIC :: OPERATOR(.NE.) +PUBLIC :: OPERATOR(**) +PUBLIC :: ABS +PUBLIC :: Sqrt +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/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index dbce371d5..01b894b21 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -18,21 +18,19 @@ 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 - ${src_path}/FEVariable_Method@ScalarInterpolationMethods.F90 - ${src_path}/FEVariable_Method@VectorInterpolationMethods.F90 - ${src_path}/FEVariable_Method@MatrixInterpolationMethods.F90 - ${src_path}/FEVariable_Method@InterpolationMethods.F90) + 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_InterpolationMethod@ScalarMethods.F90 + ${src_path}/FEVariable_InterpolationMethod@VectorMethods.F90 + ${src_path}/FEVariable_InterpolationMethod@MatrixMethods.F90 + ${src_path}/FEVariable_InterpolationMethod@Methods.F90) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90 index 68d095928..2fc8a85ae 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90 @@ -15,11 +15,11 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) AdditionMethods - +SUBMODULE(FEVariable_AdditionMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, & Nodal, Quadrature + USE BaseType, ONLY: TypeFEVariableScalar, & TypeFEVariableVector, & TypeFEVariableMatrix, & @@ -30,6 +30,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ + IMPLICIT NONE @@ -103,5 +105,5 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE AdditionMethods +END SUBMODULE Methods #undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 similarity index 54% rename from src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 index d7e92e320..554e6be72 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 @@ -15,64 +15,56 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) EqualMethods -USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) +SUBMODULE(FEVariable_ConstructorMethod) Methods +USE ReallocateUtility, ONLY: Reallocate IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! NORM2 +! Deallocate !---------------------------------------------------------------------------- -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 +MODULE PROCEDURE fevar_Deallocate +IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) +obj%s = 0 +obj%defineOn = 0 +obj%varType = 0 +obj%rank = 0 +obj%len = 0 +obj%capacity = 0 +obj%isInit = .FALSE. +END PROCEDURE fevar_Deallocate !---------------------------------------------------------------------------- -! NORM2 +! Copy !---------------------------------------------------------------------------- -MODULE PROCEDURE fevar_notEqual -ans = .FALSE. -IF (.NOT. ALL(obj1%val.APPROXEQ.obj2%val)) THEN - ans = .TRUE. - RETURN -END IF +MODULE PROCEDURE obj_Copy +LOGICAL(LGT) :: isok -IF (obj1%defineon .NE. obj2%defineon) THEN - ans = .TRUE. - RETURN -END IF +obj1%s = obj2%s +obj1%defineOn = obj2%defineOn +obj1%rank = obj2%rank +obj1%varType = obj2%varType +obj1%len = obj2%len +obj1%isInit = obj2%isInit -IF (obj1%rank .NE. obj2%rank) THEN - ans = .TRUE. +IF (obj1%capacity .GE. obj1%len) THEN + obj1%val(1:obj1%len) = obj2%val(1:obj1%len) RETURN END IF -IF (obj1%varType .NE. obj2%varType) THEN - ans = .TRUE. - RETURN -END IF +obj1%capacity = TypeFEVariableOpt%capacityExpandFactor * obj1%len +CALL Reallocate(obj1%val, obj1%capacity) -IF (ANY(obj1%s .NE. obj2%s)) THEN - ans = .TRUE. - RETURN -END IF +isok = ALLOCATED(obj2%val) +IF (isok) obj1%val(1:obj1%len) = obj2%val(1:obj1%len) -END PROCEDURE fevar_notEqual +END PROCEDURE obj_Copy !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -END SUBMODULE EqualMethods +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 96% rename from src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90 index 3046f33bf..287a9b1ca 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90 @@ -15,10 +15,11 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) DivisionMethods +SUBMODULE(FEVariable_DivisionMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, & Nodal, Quadrature + USE BaseType, ONLY: TypeFEVariableScalar, & TypeFEVariableVector, & TypeFEVariableMatrix, & @@ -29,6 +30,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ / IMPLICIT NONE @@ -126,4 +129,4 @@ !---------------------------------------------------------------------------- #undef _OP_ -END SUBMODULE DivisionMethods +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_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 similarity index 99% rename from src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 index 9c64bb173..2c18526da 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 @@ -14,7 +14,7 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -SUBMODULE(FEVariable_Method) GetMethods +SUBMODULE(FEVariable_GetMethod) Methods USE ReallocateUtility, ONLY: Reallocate USE StringUtility, ONLY: UpperCase @@ -491,4 +491,4 @@ END SUBROUTINE Master_get_mat4_ ! !---------------------------------------------------------------------------- -END SUBMODULE GetMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 similarity index 97% rename from src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 index a23f83724..0d33196bc 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) IOMethods +SUBMODULE(FEVariable_IOMethod) Methods USE Display_Method, ONLY: Util_Display => Display, ToString USE GlobalData, ONLY: Scalar, Vector, Matrix, & @@ -32,6 +32,8 @@ USE SafeSizeUtility, ONLY: SafeSize +USE FEVariable_Method, ONLY: GET, NodalVariable, QuadratureVariable + IMPLICIT NONE CONTAINS @@ -136,4 +138,4 @@ END PROCEDURE fevar_Display -END SUBMODULE IOMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 similarity index 98% rename from src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 index 912b3e31e..436c1acad 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@MatrixInterpolationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 @@ -16,7 +16,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) MatrixInterpolationMethods +SUBMODULE(FEVariable_InterpolationMethod) MatrixMethods IMPLICIT NONE CONTAINS @@ -182,4 +182,4 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature_ END SELECT END PROCEDURE MatrixSpaceTimeGetInterpolation_ -END SUBMODULE MatrixInterpolationMethods +END SUBMODULE MatrixMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 similarity index 92% rename from src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 index f28dbc637..c99da1fae 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@InterpolationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 @@ -16,7 +16,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) InterpolationMethods +SUBMODULE(FEVariable_InterpolationMethod) Methods IMPLICIT NONE CONTAINS @@ -28,4 +28,4 @@ END PROCEDURE FEVariableGetInterpolation_1 -END SUBMODULE InterpolationMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@ScalarMethods.F90 similarity index 97% rename from src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_InterpolationMethod@ScalarMethods.F90 index 2b2d3e866..daae29cdc 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@ScalarInterpolationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@ScalarMethods.F90 @@ -16,7 +16,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) ScalarInterpolationMethods +SUBMODULE(FEVariable_InterpolationMethod) ScalarMethods IMPLICIT NONE CONTAINS @@ -127,4 +127,4 @@ END SUBROUTINE MasterGetInterpolation_ END PROCEDURE ScalarSpaceTimeGetInterpolation_ -END SUBMODULE ScalarInterpolationMethods +END SUBMODULE ScalarMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@VectorMethods.F90 similarity index 98% rename from src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_InterpolationMethod@VectorMethods.F90 index 4c18de3e4..dafd1e288 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@VectorInterpolationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@VectorMethods.F90 @@ -16,7 +16,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) VectorInterpolationMethods +SUBMODULE(FEVariable_InterpolationMethod) VectorMethods IMPLICIT NONE CONTAINS @@ -171,4 +171,4 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature_ END PROCEDURE VectorSpaceTimeGetInterpolation_ -END SUBMODULE VectorInterpolationMethods +END SUBMODULE VectorMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 b/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 similarity index 97% rename from src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 index 979dc3e8f..7ff5c9dba 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) MeanMethods +SUBMODULE(FEVariable_MeanMethod) Methods USE IntegerUtility, ONLY: Get1DIndexFortran USE GlobalData, ONLY: Scalar, Vector, Matrix, & @@ -30,6 +30,8 @@ TypeFEVariableTime, & TypeFEVariableSpaceTime +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + IMPLICIT NONE CONTAINS @@ -38,7 +40,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Mean1 -REAL(DFP) :: val0 SELECT CASE (obj%rank) CASE (scalar) IF (obj%defineOn .EQ. NODAL) THEN @@ -173,4 +174,4 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE MeanMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 deleted file mode 100644 index 6cecc69f9..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 +++ /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 -! - -#define _ELEM_METHOD_ ABS - -SUBMODULE(FEVariable_Method) AbsMethods - -USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & - Scalar, Vector, Matrix, & - Nodal, Quadrature - -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime - -IMPLICIT NONE - -CONTAINS - -!---------------------------------------------------------------------------- -! Abs -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_Abs -SELECT CASE (obj%rank) - -CASE (scalar) -#include "./include/ScalarElemMethod.F90" - -CASE (vector) -#include "./include/VectorElemMethod.F90" - -CASE (matrix) -#include "./include/MatrixElemMethod.F90" - -END SELECT - -END PROCEDURE fevar_Abs - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE AbsMethods - -#undef _ELEM_METHOD_ 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@SqrtMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 deleted file mode 100644 index 6dbcbef79..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 +++ /dev/null @@ -1,56 +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 -! - -#define _ELEM_METHOD_ SQRT - -SUBMODULE(FEVariable_Method) SqrtMethods -USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & - Scalar, Vector, Matrix, & - Nodal, Quadrature -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SQRT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_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 -END PROCEDURE fevar_sqrt - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE SqrtMethods - -#undef _ELEM_METHOD_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90 index 2c72ac268..348971c5c 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90 @@ -15,8 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) MultiplicationMethods - +SUBMODULE(FEVariable_MultiplicationMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, Nodal, Quadrature @@ -30,6 +29,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ * IMPLICIT NONE @@ -105,4 +106,5 @@ !---------------------------------------------------------------------------- #undef _OP_ -END SUBMODULE MultiplicationMethods + +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..2016a697f --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 @@ -0,0 +1,231 @@ +! 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 GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & + Time, SpaceTime, Nodal, Quadrature + +USE ReallocateUtility, ONLY: Reallocate + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Constant +#define _DEFINEON_ Nodal +#include "./include/scalar_constant.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_Constant + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Space +#define _DEFINEON_ Nodal +#include "./include/scalar_space.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_Space + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Time +#define _DEFINEON_ Nodal +#include "./include/scalar_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_Time + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_SpaceTime +#define _DEFINEON_ Nodal +#include "./include/scalar_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_SpaceTime2 +#define _DEFINEON_ Nodal +#include "./include/scalar_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Scalar_SpaceTime2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Constant +#define _DEFINEON_ Nodal +#include "./include/vector_constant.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Constant + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Space +#define _DEFINEON_ Nodal +#include "./include/vector_space.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Space + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Space2 +#define _DEFINEON_ Nodal +#include "./include/vector_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Time +#define _DEFINEON_ Nodal +#include "./include/vector_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Time + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Time2 +#define _DEFINEON_ Nodal +#include "./include/vector_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_Time2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime +#define _DEFINEON_ Nodal +#include "./include/vector_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime2 +#define _DEFINEON_ Nodal +#include "./include/vector_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Vector_SpaceTime2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Constant +#define _DEFINEON_ Nodal +#include "./include/matrix_constant.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Constant + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Constant2 +#define _DEFINEON_ Nodal +#include "./include/matrix_constant2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Constant2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Space +#define _DEFINEON_ Nodal +#include "./include/matrix_space.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Space + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Space2 +#define _DEFINEON_ Nodal +#include "./include/matrix_space2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Time +#define _DEFINEON_ Nodal +#include "./include/matrix_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Time + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Time2 +#define _DEFINEON_ Nodal +#include "./include/matrix_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_Time2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime +#define _DEFINEON_ Nodal +#include "./include/matrix_space_time.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime2 +#define _DEFINEON_ Nodal +#include "./include/matrix_space_time2.F90" +#undef _DEFINEON_ +END PROCEDURE Nodal_Matrix_SpaceTime2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 similarity index 50% rename from src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 index 8c6be5c29..bd59ecf57 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) ConstructorMethods +SUBMODULE(FEVariable_QuadratureVariableMethod) Methods USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & Time, SpaceTime, Nodal, Quadrature @@ -24,221 +24,6 @@ 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 -obj%len = 0 -obj%capacity = 0 -obj%isInit = .FALSE. -END PROCEDURE fevar_Deallocate - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Scalar_Constant -#define _DEFINEON_ Nodal -#include "./include/scalar_constant.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Scalar_Constant - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Scalar_Space -#define _DEFINEON_ Nodal -#include "./include/scalar_space.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Scalar_Space - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Scalar_Time -#define _DEFINEON_ Nodal -#include "./include/scalar_time.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Scalar_Time - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Scalar_SpaceTime -#define _DEFINEON_ Nodal -#include "./include/scalar_space_time.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Scalar_SpaceTime - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Scalar_SpaceTime2 -#define _DEFINEON_ Nodal -#include "./include/scalar_space_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Scalar_SpaceTime2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_Constant -#define _DEFINEON_ Nodal -#include "./include/vector_constant.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_Constant - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_Space -#define _DEFINEON_ Nodal -#include "./include/vector_space.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_Space - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_Space2 -#define _DEFINEON_ Nodal -#include "./include/vector_space2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_Space2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_Time -#define _DEFINEON_ Nodal -#include "./include/vector_time.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_Time - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_Time2 -#define _DEFINEON_ Nodal -#include "./include/vector_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_Time2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_SpaceTime -#define _DEFINEON_ Nodal -#include "./include/vector_space_time.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_SpaceTime - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Vector_SpaceTime2 -#define _DEFINEON_ Nodal -#include "./include/vector_space_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Vector_SpaceTime2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_Constant -#define _DEFINEON_ Nodal -#include "./include/matrix_constant.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_Constant - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_Constant2 -#define _DEFINEON_ Nodal -#include "./include/matrix_constant2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_Constant2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_Space -#define _DEFINEON_ Nodal -#include "./include/matrix_space.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_Space - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_Space2 -#define _DEFINEON_ Nodal -#include "./include/matrix_space2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_Space2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_Time -#define _DEFINEON_ Nodal -#include "./include/matrix_time.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_Time - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_Time2 -#define _DEFINEON_ Nodal -#include "./include/matrix_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_Time2 - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_SpaceTime -#define _DEFINEON_ Nodal -#include "./include/matrix_space_time.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_SpaceTime - -!---------------------------------------------------------------------------- -! NodalVariable -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Nodal_Matrix_SpaceTime2 -#define _DEFINEON_ Nodal -#include "./include/matrix_space_time2.F90" -#undef _DEFINEON_ -END PROCEDURE Nodal_Matrix_SpaceTime2 - !---------------------------------------------------------------------------- ! QuadratureVariable !---------------------------------------------------------------------------- @@ -439,35 +224,8 @@ #undef _DEFINEON_ END PROCEDURE Quadrature_Matrix_SpaceTime2 -!---------------------------------------------------------------------------- -! Copy -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Copy -LOGICAL(LGT) :: isok - -obj1%s = obj2%s -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 = CAPACITY_EXPAND_FACTOR * 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 ConstructorMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90 index ab1f27b03..809c3a34b 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) SubtractionMethods +SUBMODULE(FEVariable_SubtractionMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, & @@ -30,6 +30,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ - IMPLICIT NONE @@ -138,5 +140,5 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE SubtractionMethods +END SUBMODULE Methods #undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 b/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 similarity index 51% rename from src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 rename to src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 index 558a09ecd..5697bd0fc 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 @@ -15,12 +15,11 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) Norm2Methods -USE IntegerUtility, ONLY: Get1DIndexFortran - -USE GlobalData, ONLY: Scalar, Vector, Matrix, & - Constant, Space, Time, & - SpaceTime, Nodal, Quadrature +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, & @@ -30,12 +29,119 @@ 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 !---------------------------------------------------------------------------- @@ -120,4 +226,5 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE Norm2Methods +END SUBMODULE Methods + diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90 index af887ec55..7e8491cc5 100644 --- a/src/submodules/FEVariable/src/include/matrix_constant.F90 +++ b/src/submodules/FEVariable/src/include/matrix_constant.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 diff --git a/src/submodules/FEVariable/src/include/matrix_constant2.F90 b/src/submodules/FEVariable/src/include/matrix_constant2.F90 index f9eb28649..c3d68affd 100644 --- a/src/submodules/FEVariable/src/include/matrix_constant2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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) diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90 index 6ea254890..2c8fe66eb 100644 --- a/src/submodules/FEVariable/src/include/matrix_space.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, kk, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 diff --git a/src/submodules/FEVariable/src/include/matrix_space2.F90 b/src/submodules/FEVariable/src/include/matrix_space2.F90 index b82372f7e..e3a3720ad 100644 --- a/src/submodules/FEVariable/src/include/matrix_space2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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) diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90 index 9e445c8af..6196e6deb 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90 @@ -1,7 +1,7 @@ INTEGER(I4B) :: ii, jj, kk, ll, 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 diff --git a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 index 8aed83e31..d56b5d2b9 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 @@ -1,5 +1,5 @@ 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) diff --git a/src/submodules/FEVariable/src/include/matrix_time.F90 b/src/submodules/FEVariable/src/include/matrix_time.F90 index 3bdc1544e..3ed2f7abe 100644 --- a/src/submodules/FEVariable/src/include/matrix_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, kk, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 diff --git a/src/submodules/FEVariable/src/include/matrix_time2.F90 b/src/submodules/FEVariable/src/include/matrix_time2.F90 index 1b4b4a80e..802a8533d 100644 --- a/src/submodules/FEVariable/src/include/matrix_time2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_time2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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) diff --git a/src/submodules/FEVariable/src/include/scalar_constant.F90 b/src/submodules/FEVariable/src/include/scalar_constant.F90 index 94597f6a9..196477a21 100644 --- a/src/submodules/FEVariable/src/include/scalar_constant.F90 +++ b/src/submodules/FEVariable/src/include/scalar_constant.F90 @@ -1,5 +1,6 @@ obj%len = 1 -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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 diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90 index bd0c481a1..e4e6105f3 100644 --- a/src/submodules/FEVariable/src/include/scalar_space.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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) = SIZE(val) diff --git a/src/submodules/FEVariable/src/include/scalar_space_time.F90 b/src/submodules/FEVariable/src/include/scalar_space_time.F90 index ed8d43619..1f52da872 100644 --- a/src/submodules/FEVariable/src/include/scalar_space_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, kk obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) kk = 0 diff --git a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 index 19ee3e1bd..5b654bea4 100644 --- a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!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) diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90 index cf5060ffb..febf06f04 100644 --- a/src/submodules/FEVariable/src/include/scalar_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_time.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!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) = SIZE(val) diff --git a/src/submodules/FEVariable/src/include/vector_constant.F90 b/src/submodules/FEVariable/src/include/vector_constant.F90 index 6c2d602a0..47e1ca5f0 100644 --- a/src/submodules/FEVariable/src/include/vector_constant.F90 +++ b/src/submodules/FEVariable/src/include/vector_constant.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val diff --git a/src/submodules/FEVariable/src/include/vector_space.F90 b/src/submodules/FEVariable/src/include/vector_space.F90 index 91f13691b..173945c30 100644 --- a/src/submodules/FEVariable/src/include/vector_space.F90 +++ b/src/submodules/FEVariable/src/include/vector_space.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 diff --git a/src/submodules/FEVariable/src/include/vector_space2.F90 b/src/submodules/FEVariable/src/include/vector_space2.F90 index db7eb132b..44cb5b65d 100644 --- a/src/submodules/FEVariable/src/include/vector_space2.F90 +++ b/src/submodules/FEVariable/src/include/vector_space2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!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) diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90 index b6e15e8a3..fbb4beaa0 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, kk, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 diff --git a/src/submodules/FEVariable/src/include/vector_space_time2.F90 b/src/submodules/FEVariable/src/include/vector_space_time2.F90 index 2083899ec..448ee6c8d 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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) diff --git a/src/submodules/FEVariable/src/include/vector_time.F90 b/src/submodules/FEVariable/src/include/vector_time.F90 index e60381c70..fa00f6144 100644 --- a/src/submodules/FEVariable/src/include/vector_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 diff --git a/src/submodules/FEVariable/src/include/vector_time2.F90 b/src/submodules/FEVariable/src/include/vector_time2.F90 index 3310c0176..580deb7a7 100644 --- a/src/submodules/FEVariable/src/include/vector_time2.F90 +++ b/src/submodules/FEVariable/src/include/vector_time2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! 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) From 54f2bf672c7da969d168d68193bae09290d54d3a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Sep 2025 15:18:38 +0900 Subject: [PATCH 032/184] Updating ElemShapeData adding new interpolation method --- .../src/ElemshapeData_InterpolMethods.F90 | 138 ++++++++++++++++-- .../ElemshapeData_InterpolMethods@Methods.F90 | 54 ++++++- ...hapeData_MatrixInterpolMethods@Methods.F90 | 81 +++++----- 3 files changed, 216 insertions(+), 57 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index 4e4b939f5..84d8bc807 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -27,7 +27,7 @@ MODULE ElemshapeData_InterpolMethods PUBLIC :: Interpolation !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -47,15 +47,74 @@ MODULE ElemshapeData_InterpolMethods ! - The `vartype` of val can be constant, space, time, spacetime ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE master_getInterpolation_1(obj, ans, val) + MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE master_getInterpolation_1 + END SUBROUTINE GetInterpolation1 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of a FEVariable +! +!# Introduction +! +! - 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 GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: ans + TYPE(FEVariable_), INTENT(IN) :: val + END SUBROUTINE GetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of a FEVariable +! +!# Introduction +! +! - 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 GetInterpolation_ + 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 + REAL(DFP), INTENT(IN) :: scale + LOGICAL, INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_1a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -75,15 +134,74 @@ END SUBROUTINE master_getInterpolation_1 ! - The `vartype` of val can be constant, space, time, spacetime ! INTERFACE GetInterpolation - MODULE PURE SUBROUTINE master_getInterpolation_2(obj, ans, val) + MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE master_getInterpolation_2 + END SUBROUTINE GetInterpolation2 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- -! Interpolation@InterpolMethods +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! 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 +! +! - 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 GetInterpolation_ + 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 GetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-01 +! summary: returns the interpolation of a FEVariable +! +!# Introduction +! +! - 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 GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: ans + TYPE(FEVariable_), INTENT(IN) :: val + REAL(DFP), INTENT(IN) :: scale + LOGICAL, INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_2a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! Interpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -92,15 +210,15 @@ END SUBROUTINE master_getInterpolation_2 ! 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 END MODULE ElemshapeData_InterpolMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index 8e3756378..d93034859 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -17,14 +17,16 @@ SUBMODULE(ElemshapeData_InterpolMethods) Methods USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ + IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! getinterpolation +! GetInterpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE master_getinterpolation_1 +MODULE PROCEDURE GetInterpolation1 ! REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) ! !! main ! !! @@ -54,13 +56,35 @@ ! & typeFEVariableSpace) ! DEALLOCATE (r3) ! END SELECT -END PROCEDURE master_getinterpolation_1 +END PROCEDURE GetInterpolation1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL, PARAMETER :: no = .FALSE. + +CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, & + nips=obj%nips, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1a +CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, & + nips=obj%nips, scale=scale, & + addContribution=addContribution) +END PROCEDURE GetInterpolation_1a !---------------------------------------------------------------------------- -! getInterpolation +! GetInterpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE master_getInterpolation_2 +MODULE PROCEDURE GetInterpolation2 ! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :) ! !! main ! !! @@ -91,14 +115,28 @@ ! DEALLOCATE (r4) ! END SELECT ! !! -END PROCEDURE master_getInterpolation_2 +END PROCEDURE GetInterpolation2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2 +END PROCEDURE GetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2a +END PROCEDURE GetInterpolation_2a !---------------------------------------------------------------------------- ! interpolationOfVector !---------------------------------------------------------------------------- -MODULE PROCEDURE master_interpolation_1 +MODULE PROCEDURE Interpolation1 ! CALL getInterpolation(obj=obj, val=val, ans=ans) -END PROCEDURE master_interpolation_1 +END PROCEDURE Interpolation1 END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 index 09f006724..30069bfdc 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 @@ -17,7 +17,11 @@ SUBMODULE(ElemshapeData_MatrixInterpolMethods) Methods USE ReallocateUtility, ONLY: Reallocate -USE FEVariable_Method, ONLY: FEVariableSize => Size +USE FEVariable_Method, ONLY: FEVariableSize => Size, & + FEVariableGetInterpolation_ => GetInterpolation_ +USE BaseType, ONLY: TypeFEVariableMatrix, TypeFEVariableConstant, & + TypeFEVariableSpace, TypeFEVariableSpaceTime, & + TypeFEVariableOpt IMPLICIT NONE CONTAINS @@ -227,42 +231,41 @@ !---------------------------------------------------------------------------- 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 +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 !---------------------------------------------------------------------------- @@ -320,7 +323,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Interpolation1 -! interpol = MATMUL(val, obj%N) +CALL GetInterpolation(obj=obj, val=val, ans=ans) END PROCEDURE Interpolation1 !---------------------------------------------------------------------------- @@ -328,7 +331,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE STInterpolation1 -! interpol = MATMUL(MATMUL(val, obj%T), obj%N) +CALL GetInterpolation(obj=obj, val=val, ans=ans) END PROCEDURE STInterpolation1 END SUBMODULE Methods From 418155cdcf30bc2bae4fa29c756800585ceeba27 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Sep 2025 12:41:16 +0900 Subject: [PATCH 033/184] Updating FEVariable Adding Interpolation methods --- src/modules/FEVariable/CMakeLists.txt | 3 + .../src/FEVariable_InterpolationMethod.F90 | 354 +---------------- .../FEVariable_MatrixInterpolationMethod.F90 | 268 +++++++++++++ .../FEVariable/src/FEVariable_Method.F90 | 3 + .../FEVariable_ScalarInterpolationMethod.F90 | 280 +++++++++++++ .../FEVariable/src/FEVariable_UnaryMethod.F90 | 6 +- .../FEVariable_VectorInterpolationMethod.F90 | 287 ++++++++++++++ src/submodules/FEVariable/CMakeLists.txt | 6 +- ...able_InterpolationMethod@MatrixMethods.F90 | 185 --------- ...FEVariable_InterpolationMethod@Methods.F90 | 172 +++++++- ...able_InterpolationMethod@VectorMethods.F90 | 174 --------- ...able_MatrixInterpolationMethod@Methods.F90 | 368 ++++++++++++++++++ ...ble_ScalarInterpolationMethod@Methods.F90} | 111 +++++- ...able_VectorInterpolationMethod@Methods.F90 | 346 ++++++++++++++++ 14 files changed, 1844 insertions(+), 719 deletions(-) create mode 100644 src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 create mode 100644 src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 delete mode 100644 src/submodules/FEVariable/src/FEVariable_InterpolationMethod@VectorMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 rename src/submodules/FEVariable/src/{FEVariable_InterpolationMethod@ScalarMethods.F90 => FEVariable_ScalarInterpolationMethod@Methods.F90} (52%) create mode 100644 src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 diff --git a/src/modules/FEVariable/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt index bbe9030df..9e35caea3 100644 --- a/src/modules/FEVariable/CMakeLists.txt +++ b/src/modules/FEVariable/CMakeLists.txt @@ -31,6 +31,9 @@ target_sources( ${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) diff --git a/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 index 021cefcb6..221426688 100644 --- a/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 @@ -16,157 +16,29 @@ MODULE FEVariable_InterpolationMethod USE BaseType, ONLY: FEVariable_, & - FEVariableScalar_, & - FEVariableVector_, & - 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 scalar, constant - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_(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_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! GetInterpolation_@ScalarInterpolationMethods +! GetInterpolation_@InterpolationMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2025-08-29 -! summary: Get interpolation of scalar, space +! summary: Get interpolation of Matrix, space-time INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_(obj, rank, vartype, & - N, nns, nips, & + MODULE PURE SUBROUTINE FEVariableGetInterpolation_1(obj, 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_ -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_(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_ -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_(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - ans, nrow, ncol) + 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 @@ -178,240 +50,46 @@ MODULE PURE SUBROUTINE VectorConstantGetInterpolation_(obj, rank, vartype, & !! 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_ + 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_@VectorInterpolationMethods +! GetInterpolation_@InterpolationMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2025-08-29 -! summary: Get interpolation of Vector, space +! summary: Get interpolation of Matrix, space-time INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_(obj, rank, vartype, & - N, nns, nips, & - scale, & + MODULE PURE SUBROUTINE FEVariableGetInterpolation_2(obj, N, nns, nips, & + T, nnt, 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_ -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_(obj, rank, & - vartype, & - N, nns, nips, & - T, nnt, & - scale, & - addContribution, & - ans, nrow, ncol, & - timeIndx) + 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 + !! shape functions data, T(I) : I is 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_ -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_(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_ -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_(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_ -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_(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_ -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_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 + !! time index TYPE(FEVariable_), INTENT(INOUT) :: ans !! Interpolated value in FEVariable_ format - END SUBROUTINE FEVariableGetInterpolation_1 + 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..6e07fb2dc --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 @@ -0,0 +1,268 @@ +! 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_@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-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_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_MatrixInterpolationMethod diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 82fc2ee0a..bc1eb2b1f 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -29,6 +29,9 @@ MODULE FEVariable_Method USE FEVariable_GetMethod +USE FEVariable_ScalarInterpolationMethod +USE FEVariable_VectorInterpolationMethod +USE FEVariable_MatrixInterpolationMethod USE FEVariable_InterpolationMethod USE FEVariable_IOMethod diff --git a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 new file mode 100644 index 000000000..6db231a1a --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 @@ -0,0 +1,280 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +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_@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-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_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_ScalarInterpolationMethod diff --git a/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 b/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 index 36ac322ed..ef59f1d6e 100644 --- a/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 @@ -31,11 +31,11 @@ MODULE FEVariable_UnaryMethod PRIVATE -PUBLIC :: OPERATOR(.EQ.) -PUBLIC :: OPERATOR(.NE.) -PUBLIC :: OPERATOR(**) PUBLIC :: ABS +PUBLIC :: OPERATOR(**) PUBLIC :: Sqrt +PUBLIC :: OPERATOR(.EQ.) +PUBLIC :: OPERATOR(.NE.) PUBLIC :: Norm2 !---------------------------------------------------------------------------- diff --git a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 new file mode 100644 index 000000000..b17870538 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.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 + +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_@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-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_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_VectorInterpolationMethod diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index 01b894b21..32fddf33f 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -30,7 +30,7 @@ target_sources( ${src_path}/FEVariable_UnaryMethod@Methods.F90 ${src_path}/FEVariable_GetMethod@Methods.F90 ${src_path}/FEVariable_IOMethod@Methods.F90 - ${src_path}/FEVariable_InterpolationMethod@ScalarMethods.F90 - ${src_path}/FEVariable_InterpolationMethod@VectorMethods.F90 - ${src_path}/FEVariable_InterpolationMethod@MatrixMethods.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) diff --git a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 deleted file mode 100644 index 436c1acad..000000000 --- a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@MatrixMethods.F90 +++ /dev/null @@ -1,185 +0,0 @@ -! 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) MatrixMethods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetInterpolation_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MatrixConstantGetInterpolation_ -INTEGER(I4B) :: ips, jj, istart, iend - -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 - istart = (jj - 1) * dim1 + 1 - iend = jj * dim1 - ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & - + scale * obj%val(istart:iend) - END DO -END DO -END PROCEDURE MatrixConstantGetInterpolation_ - -!---------------------------------------------------------------------------- -! MasterGetInterpolation_ -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MasterGetInterpolationFromNodal_(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, jj, istart, iend - - DO ips = 1, nips - DO jj = 1, dim2 - istart = (jj - 1) * dim1 + 1 + valStart - iend = jj * dim1 + valStart - ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & - + scale * N(jj, ips) * val(istart:iend) - END DO - END DO - - valEnd = valStart + nns * dim1 * dim2 - -END SUBROUTINE MasterGetInterpolationFromNodal_ - -!---------------------------------------------------------------------------- -! MasterGetInterpolation_ -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MasterGetInterpolationFromQuadrature_(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, istart, iend, jj - - DO ips = 1, nips - DO jj = 1, dim2 - istart = (jj - 1) * dim1 + 1 + valStart - iend = jj * dim1 + valStart - ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) + scale * val(istart:iend) - END DO - END DO - - valEnd = valStart + nips * dim1 * dim2 - -END SUBROUTINE MasterGetInterpolationFromQuadrature_ - -!---------------------------------------------------------------------------- -! GetInterpolation_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MatrixSpaceGetInterpolation_ -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%varType) -CASE (TypeFEVariableOpt%nodal) - !! Nodal Matrix Space - !! Convert nodal values to quadrature values by using N(:,:) - !! make sure nns .LE. obj%len - - CALL MasterGetInterpolationFromNodal_(ans=ans, scale=scale, N=N, & - nns=nns, nips=nips, val=obj%val, & - dim1=dim1, dim2=dim2, & - valStart=0, valEnd=valEnd) - -CASE (TypeFEVariableOpt%quadrature) - !! No need for interpolation, just returnt the quadrature values - !! make sure nips .LE. obj%len - - CALL MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & - nips=nips, dim1=dim1, & - dim2=dim2, val=obj%val, & - valStart=0, valEnd=valEnd) - -END SELECT -END PROCEDURE MatrixSpaceGetInterpolation_ - -!---------------------------------------------------------------------------- -! GetInterpolation_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_ -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%varType) -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 MasterGetInterpolationFromNodal_(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) - !! No need for interpolation, just returnt the quadrature values - !! make sure nips .LE. obj%len - - valStart = nips * dim1 * dim2 * (timeIndx - 1) - CALL MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & - dim1=dim1, dim2=dim2, & - nips=nips, val=obj%val, & - valStart=valStart, valEnd=valEnd) - -END SELECT -END PROCEDURE MatrixSpaceTimeGetInterpolation_ - -END SUBMODULE MatrixMethods diff --git a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 index c99da1fae..65e187578 100644 --- a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 @@ -14,9 +14,18 @@ ! ! 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 @@ -25,7 +34,168 @@ !---------------------------------------------------------------------------- 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_InterpolationMethod@VectorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@VectorMethods.F90 deleted file mode 100644 index dafd1e288..000000000 --- a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@VectorMethods.F90 +++ /dev/null @@ -1,174 +0,0 @@ -! 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) VectorMethods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! GetInterpolation_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VectorConstantGetInterpolation_ -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_ - -!---------------------------------------------------------------------------- -! MasterGetInterpolation_ -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MasterGetInterpolationFromNodal_(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 MasterGetInterpolationFromNodal_ - -!---------------------------------------------------------------------------- -! MasterGetInterpolation_ -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MasterGetInterpolationFromQuadrature_(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 MasterGetInterpolationFromQuadrature_ - -!---------------------------------------------------------------------------- -! GetInterpolation_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VectorSpaceGetInterpolation_ -INTEGER(I4B) :: valEnd - -nrow = obj%s(1) -ncol = nips -IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP - -SELECT CASE (obj%varType) -CASE (TypeFEVariableOpt%nodal) - !! Nodal Vector Space - !! Convert nodal values to quadrature values by using N(:,:) - !! make sure nns .LE. obj%len - - CALL MasterGetInterpolationFromNodal_(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 MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & - nsd=nrow, nips=nips, & - val=obj%val, valStart=0, & - valEnd=valEnd) - -END SELECT - -END PROCEDURE VectorSpaceGetInterpolation_ - -!---------------------------------------------------------------------------- -! GetInterpolation_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VectorSpaceTimeGetInterpolation_ -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%varType) -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 MasterGetInterpolationFromNodal_(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 MasterGetInterpolationFromQuadrature_(ans=ans, scale=scale, & - nsd=nrow, nips=nips, & - val=obj%val, & - valStart=valStart, & - valEnd=valEnd) - -END SELECT - -END PROCEDURE VectorSpaceTimeGetInterpolation_ - -END SUBMODULE VectorMethods 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..58c52f777 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 @@ -0,0 +1,368 @@ +! 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 +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixConstantGetInterpolation_1 +INTEGER(I4B) :: ips, jj, istart, iend + +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 + istart = (jj - 1) * dim1 + 1 + iend = jj * dim1 + ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & + + scale * obj%val(istart:iend) + 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 + +!---------------------------------------------------------------------------- +! 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, jj, istart, iend + + DO ips = 1, nips + DO jj = 1, dim2 + istart = (jj - 1) * dim1 + 1 + valStart + iend = jj * dim1 + valStart + ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & + + scale * N(jj, ips) * val(istart:iend) + END DO + END DO + + valEnd = valStart + nns * dim1 * dim2 + +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 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, istart, iend, jj + + DO ips = 1, nips + DO jj = 1, dim2 + istart = (jj - 1) * dim1 + 1 + valStart + iend = jj * dim1 + valStart + ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) + scale * val(istart:iend) + END DO + END DO + + valEnd = valStart + nips * dim1 * dim2 + +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_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%vartype is nodal +! Nodal Matrix Space +! Convert nodal values to quadrature values by using N(:,:) +! make sure nns .LE. obj%len +! +! obj%vartype 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%varType) +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%varType) +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_ +!---------------------------------------------------------------------------- + +! 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%varType) +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%varType) +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@ScalarMethods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 similarity index 52% rename from src/submodules/FEVariable/src/FEVariable_InterpolationMethod@ScalarMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 index daae29cdc..25a1d86c5 100644 --- a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@ScalarMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 @@ -16,7 +16,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_InterpolationMethod) ScalarMethods +SUBMODULE(FEVariable_ScalarInterpolationMethod) Methods IMPLICIT NONE CONTAINS @@ -24,7 +24,7 @@ ! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE ScalarConstantGetInterpolation_ +MODULE PROCEDURE ScalarConstantGetInterpolation_1 INTEGER(I4B) :: ii tsize = nips @@ -33,36 +33,52 @@ DO ii = 1, tsize ans(ii) = ans(ii) + scale * obj%val(1) END DO -END PROCEDURE ScalarConstantGetInterpolation_ +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 !---------------------------------------------------------------------------- ! MasterGetInterpolation_ !---------------------------------------------------------------------------- PURE SUBROUTINE MasterGetInterpolation_(ans, scale, N, nns, nips, val, & - valStart) + 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 + INTEGER(I4B), INTENT(IN) :: valStart, ansStart INTEGER(I4B) :: ips, ii DO ips = 1, nips DO ii = 1, nns - ans(ips) = ans(ips) + scale * N(ii, ips) * val(valStart + ii) + ans(ansStart + ips) = ans(ansStart + ips) & + + scale * N(ii, ips) * val(valStart + ii) END DO END DO END SUBROUTINE MasterGetInterpolation_ !---------------------------------------------------------------------------- -! GetInterpolation_ +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE ScalarSpaceGetInterpolation_ +MODULE PROCEDURE ScalarSpaceGetInterpolation_1 INTEGER(I4B) :: ips tsize = nips @@ -74,7 +90,8 @@ END SUBROUTINE MasterGetInterpolation_ !! make sure nns .LE. obj%len CALL MasterGetInterpolation_(ans=ans, scale=scale, N=N, nns=nns, & - nips=nips, val=obj%val, valStart=0) + nips=nips, val=obj%val, valStart=0, & + ansStart=0) CASE (TypeFEVariableOpt%quadrature) !! No need for interpolation, just returnt the quadrature values @@ -86,20 +103,49 @@ END SUBROUTINE MasterGetInterpolation_ END SELECT -END PROCEDURE ScalarSpaceGetInterpolation_ +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%varType) +CASE (TypeFEVariableOpt%nodal) + CALL MasterGetInterpolation_(ans=ans%val, scale=scale, N=N, & + nns=nns, nips=nips, val=obj%val, & + valStart=valStart, ansStart=ansStart) + +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_ !---------------------------------------------------------------------------- -MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_ -INTEGER(I4B) :: aa, valStart +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%varType) CASE (TypeFEVariableOpt%nodal) !! convert nodal values to quadrature values by using N @@ -111,7 +157,8 @@ END SUBROUTINE MasterGetInterpolation_ myscale = scale * T(aa) valStart = (aa - 1) * obj%s(1) CALL MasterGetInterpolation_(ans=ans, scale=myscale, N=N, nns=nns, & - nips=nips, val=obj%val, valStart=valStart) + nips=nips, val=obj%val, valStart=valStart, & + ansStart=ansStart) END DO CASE (TypeFEVariableOpt%quadrature) @@ -125,6 +172,40 @@ END SUBROUTINE MasterGetInterpolation_ END SELECT -END PROCEDURE ScalarSpaceTimeGetInterpolation_ +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%varType) + +CASE (TypeFEVariableOpt%nodal) + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = (aa - 1) * obj%s(1) + CALL MasterGetInterpolation_(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 -END SUBMODULE ScalarMethods +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..908bad4de --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 @@ -0,0 +1,346 @@ +! 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 +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! 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 + +!---------------------------------------------------------------------------- +! 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 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_ + +!---------------------------------------------------------------------------- +! 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%varType) +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%varType) +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_ +!---------------------------------------------------------------------------- + +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%varType) +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%varType) + +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 + +END SUBMODULE Methods From 776ddbffcd6b6e1c7f9321fc0430298bbd761d5c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Sep 2025 14:09:55 +0900 Subject: [PATCH 034/184] Updating ElemShapeData_Method Updating ElemShapeData_InterpolMethods --- .../src/ElemshapeData_InterpolMethods.F90 | 2 +- .../ElemshapeData_InterpolMethods@Methods.F90 | 35 ++++++++++++++++--- 2 files changed, 32 insertions(+), 5 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index 84d8bc807..24a8e06c6 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -73,7 +73,7 @@ END SUBROUTINE GetInterpolation1 ! - 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 GetInterpolation_ MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index d93034859..d11fee752 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -75,9 +75,20 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_1a -CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, & - nips=obj%nips, scale=scale, & - addContribution=addContribution) +INTEGER(I4B), PARAMETER :: timeIndx = 1 + +SELECT TYPE (obj) +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 GetInterpolation_1a !---------------------------------------------------------------------------- @@ -122,6 +133,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_2 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL, PARAMETER :: no = .FALSE. + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, scale=one, & + addContribution=no) END PROCEDURE GetInterpolation_2 !---------------------------------------------------------------------------- @@ -129,6 +145,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation_2a +INTEGER(I4B) :: aa, nipt + +nipt = SIZE(obj) + +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 !---------------------------------------------------------------------------- @@ -136,7 +163,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Interpolation1 -! CALL getInterpolation(obj=obj, val=val, ans=ans) +CALL GetInterpolation(obj=obj, val=val, ans=ans) END PROCEDURE Interpolation1 END SUBMODULE Methods From 54849ccaf615523e23ba5cd29605d225e76d901e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Sep 2025 17:01:09 +0900 Subject: [PATCH 035/184] Updating FEVariable Adding Initiate method and updating QuadratureVariable and NodalVariable method --- .../src/FEVariable_ConstructorMethod.F90 | 58 ++- .../FEVariable_ConstructorMethod@Methods.F90 | 51 ++- ...FEVariable_NodalVariableMethod@Methods.F90 | 410 +++++++++++++++--- ...iable_QuadratureVariableMethod@Methods.F90 | 327 ++++++++++---- .../FEVariable/src/include/matrix_space.F90 | 1 - .../src/include/matrix_space_time.F90 | 1 - .../FEVariable/src/include/scalar_space.F90 | 3 +- .../FEVariable/src/include/scalar_time.F90 | 3 +- 8 files changed, 696 insertions(+), 158 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 index 23c6ba337..e2b3ee888 100644 --- a/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 @@ -34,6 +34,59 @@ MODULE FEVariable_ConstructorMethod 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 @@ -41,13 +94,12 @@ MODULE FEVariable_ConstructorMethod !> author: Vikas Sharma, Ph. D. ! date: 2021-12-10 -! update: 2021-12-10 ! summary: Deallocates the content of FEVariable INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE fevar_Deallocate(obj) + MODULE PURE SUBROUTINE obj_Deallocate(obj) TYPE(FEVariable_), INTENT(INOUT) :: obj - END SUBROUTINE fevar_Deallocate + END SUBROUTINE obj_Deallocate END INTERFACE DEALLOCATE !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 index 554e6be72..51ced1a2e 100644 --- a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 @@ -21,20 +21,63 @@ 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 +INTEGER(I4B) :: tsize +LOGICAL(LGT) :: isok + +tsize = SIZE(s) +obj%isInit = .TRUE. +obj%s(1:tsize) = s(1:tsize) +obj%defineon = defineon +obj%vartype = vartype +obj%rank = rank +obj%len = len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len + +isok = ALLOCATED(obj%val) +IF (isok) THEN + 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 IF + +END PROCEDURE obj_Initiate2 + !---------------------------------------------------------------------------- ! Deallocate !---------------------------------------------------------------------------- -MODULE PROCEDURE fevar_Deallocate +MODULE PROCEDURE obj_Deallocate IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) obj%s = 0 obj%defineOn = 0 -obj%varType = 0 +obj%vartype = 0 obj%rank = 0 obj%len = 0 obj%capacity = 0 obj%isInit = .FALSE. -END PROCEDURE fevar_Deallocate +END PROCEDURE obj_Deallocate !---------------------------------------------------------------------------- ! Copy @@ -46,7 +89,7 @@ obj1%s = obj2%s obj1%defineOn = obj2%defineOn obj1%rank = obj2%rank -obj1%varType = obj2%varType +obj1%vartype = obj2%vartype obj1%len = obj2%len obj1%isInit = obj2%isInit diff --git a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 index 2016a697f..1b0161376 100644 --- a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 @@ -16,11 +16,10 @@ ! SUBMODULE(FEVariable_NodalVariableMethod) Methods -USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & - Time, SpaceTime, Nodal, Quadrature - USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate + IMPLICIT NONE CONTAINS @@ -28,200 +27,485 @@ ! NodalVariable !---------------------------------------------------------------------------- +! MODULE PROCEDURE Nodal_Scalar_Constant +! #define _DEFINEON_ Nodal +! #include "./include/scalar_constant.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Scalar_Constant + MODULE PROCEDURE Nodal_Scalar_Constant -#define _DEFINEON_ Nodal -#include "./include/scalar_constant.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/scalar_space.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Scalar_Space + MODULE PROCEDURE Nodal_Scalar_Space -#define _DEFINEON_ Nodal -#include "./include/scalar_space.F90" -#undef _DEFINEON_ +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_Time +! #define _DEFINEON_ Nodal +! #include "./include/scalar_time.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Scalar_Time + MODULE PROCEDURE Nodal_Scalar_Time -#define _DEFINEON_ Nodal -#include "./include/scalar_time.F90" -#undef _DEFINEON_ +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_SpaceTime +! #define _DEFINEON_ Nodal +! #include "./include/scalar_space_time.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Scalar_SpaceTime + MODULE PROCEDURE Nodal_Scalar_SpaceTime -#define _DEFINEON_ Nodal -#include "./include/scalar_space_time.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/scalar_space_time2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Scalar_SpaceTime2 + MODULE PROCEDURE Nodal_Scalar_SpaceTime2 -#define _DEFINEON_ Nodal -#include "./include/scalar_space_time2.F90" -#undef _DEFINEON_ +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_Vector_Constant +! #define _DEFINEON_ Nodal +! #include "./include/vector_constant.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_Constant + MODULE PROCEDURE Nodal_Vector_Constant -#define _DEFINEON_ Nodal -#include "./include/vector_constant.F90" -#undef _DEFINEON_ +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_Space +! #define _DEFINEON_ Nodal +! #include "./include/vector_space.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_Space + MODULE PROCEDURE Nodal_Vector_Space -#define _DEFINEON_ Nodal -#include "./include/vector_space.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/vector_space2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_Space2 + MODULE PROCEDURE Nodal_Vector_Space2 -#define _DEFINEON_ Nodal -#include "./include/vector_space2.F90" -#undef _DEFINEON_ +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_Time +! #define _DEFINEON_ Nodal +! #include "./include/vector_time.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_Time + MODULE PROCEDURE Nodal_Vector_Time -#define _DEFINEON_ Nodal -#include "./include/vector_time.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/vector_time2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_Time2 + MODULE PROCEDURE Nodal_Vector_Time2 -#define _DEFINEON_ Nodal -#include "./include/vector_time2.F90" -#undef _DEFINEON_ +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_SpaceTime +! #define _DEFINEON_ Nodal +! #include "./include/vector_space_time.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_SpaceTime + MODULE PROCEDURE Nodal_Vector_SpaceTime -#define _DEFINEON_ Nodal -#include "./include/vector_space_time.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/vector_space_time2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Vector_SpaceTime2 + MODULE PROCEDURE Nodal_Vector_SpaceTime2 -#define _DEFINEON_ Nodal -#include "./include/vector_space_time2.F90" -#undef _DEFINEON_ +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_Matrix_Constant +! #define _DEFINEON_ Nodal +! #include "./include/matrix_constant.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_Constant + MODULE PROCEDURE Nodal_Matrix_Constant -#define _DEFINEON_ Nodal -#include "./include/matrix_constant.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/matrix_constant2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_Constant2 + MODULE PROCEDURE Nodal_Matrix_Constant2 -#define _DEFINEON_ Nodal -#include "./include/matrix_constant2.F90" -#undef _DEFINEON_ +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_Space +! #define _DEFINEON_ Nodal +! #include "./include/matrix_space.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_Space + MODULE PROCEDURE Nodal_Matrix_Space -#define _DEFINEON_ Nodal -#include "./include/matrix_space.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/matrix_space2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_Space2 + MODULE PROCEDURE Nodal_Matrix_Space2 -#define _DEFINEON_ Nodal -#include "./include/matrix_space2.F90" -#undef _DEFINEON_ +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_Time +! #define _DEFINEON_ Nodal +! #include "./include/matrix_time.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_Time + MODULE PROCEDURE Nodal_Matrix_Time -#define _DEFINEON_ Nodal -#include "./include/matrix_time.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/matrix_time2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_Time2 + MODULE PROCEDURE Nodal_Matrix_Time2 -#define _DEFINEON_ Nodal -#include "./include/matrix_time2.F90" -#undef _DEFINEON_ +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_SpaceTime +! #define _DEFINEON_ Nodal +! #include "./include/matrix_space_time.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_SpaceTime + MODULE PROCEDURE Nodal_Matrix_SpaceTime -#define _DEFINEON_ Nodal -#include "./include/matrix_space_time.F90" -#undef _DEFINEON_ +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 +! #define _DEFINEON_ Nodal +! #include "./include/matrix_space_time2.F90" +! #undef _DEFINEON_ +! END PROCEDURE Nodal_Matrix_SpaceTime2 + MODULE PROCEDURE Nodal_Matrix_SpaceTime2 -#define _DEFINEON_ Nodal -#include "./include/matrix_space_time2.F90" -#undef _DEFINEON_ +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 !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 index bd59ecf57..91cd4b27c 100644 --- a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -16,92 +16,144 @@ ! SUBMODULE(FEVariable_QuadratureVariableMethod) Methods -USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & - Time, SpaceTime, Nodal, Quadrature - USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate + IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_Constant -#define _DEFINEON_ Quadrature -#include "./include/scalar_constant.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_Space -#define _DEFINEON_ Quadrature -#include "./include/scalar_space.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_Time -#define _DEFINEON_ Quadrature -#include "./include/scalar_time.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_SpaceTime -#define _DEFINEON_ Quadrature -#include "./include/scalar_space_time.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Scalar_SpaceTime2 -#define _DEFINEON_ Quadrature -#include "./include/scalar_space_time2.F90" -#undef _DEFINEON_ +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%scalar, len=tsize, & + val=val) END PROCEDURE Quadrature_Scalar_SpaceTime2 !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Constant -#define _DEFINEON_ Quadrature -#include "./include/vector_constant.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Space -#define _DEFINEON_ Quadrature -#include "./include/vector_space.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Space2 -#define _DEFINEON_ Quadrature -#include "./include/vector_space2.F90" -#undef _DEFINEON_ +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 !---------------------------------------------------------------------------- @@ -109,119 +161,230 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Time -#define _DEFINEON_ Quadrature -#include "./include/vector_time.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_Time2 -#define _DEFINEON_ Quadrature -#include "./include/vector_time2.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_SpaceTime -#define _DEFINEON_ Quadrature -#include "./include/vector_space_time.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Vector_SpaceTime2 -#define _DEFINEON_ Quadrature -#include "./include/vector_space_time2.F90" -#undef _DEFINEON_ +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 !---------------------------------------------------------------------------- -! QuadratureVariable +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Constant -#define _DEFINEON_ Quadrature -#include "./include/matrix_constant.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Constant2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_constant2.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Space -#define _DEFINEON_ Quadrature -#include "./include/matrix_space.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Space2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_space2.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Time -#define _DEFINEON_ Quadrature -#include "./include/matrix_time.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_Time2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_time2.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_SpaceTime -#define _DEFINEON_ Quadrature -#include "./include/matrix_space_time.F90" -#undef _DEFINEON_ +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 +! QuadratureVariable !---------------------------------------------------------------------------- MODULE PROCEDURE Quadrature_Matrix_SpaceTime2 -#define _DEFINEON_ Quadrature -#include "./include/matrix_space_time2.F90" -#undef _DEFINEON_ +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 !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90 index 2c8fe66eb..d17e017ff 100644 --- a/src/submodules/FEVariable/src/include/matrix_space.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space.F90 @@ -6,7 +6,6 @@ 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) diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90 index 6196e6deb..271a623c6 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90 @@ -5,7 +5,6 @@ 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) diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90 index e4e6105f3..1a61a03f9 100644 --- a/src/submodules/FEVariable/src/include/scalar_space.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space.F90 @@ -1,9 +1,8 @@ obj%len = SIZE(val) -! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%s(1) = obj%len obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val -obj%s(1) = SIZE(val) obj%defineOn = _DEFINEON_ obj%rank = SCALAR obj%varType = Space diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90 index febf06f04..293b2879a 100644 --- a/src/submodules/FEVariable/src/include/scalar_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_time.F90 @@ -1,9 +1,8 @@ obj%len = SIZE(val) -!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%s(1) = obj%len obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val -obj%s(1) = SIZE(val) obj%defineOn = _DEFINEON_ obj%rank = SCALAR obj%varType = Time From d207a37cf3fedbafb11bf3a6786a7f80c62bbae2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 2 Sep 2025 18:31:40 +0900 Subject: [PATCH 036/184] Updating FEVariable_Method Adding FEVariable_SetMethod Set method --- src/modules/FEVariable/CMakeLists.txt | 4 +- .../src/FEVariable_ConstructorMethod.F90 | 7 - .../FEVariable/src/FEVariable_Method.F90 | 21 +- .../FEVariable/src/FEVariable_SetMethod.F90 | 179 ++++++++++++++++++ src/submodules/FEVariable/CMakeLists.txt | 5 +- .../FEVariable_SetMethod@MatrixMethods.F90 | 114 +++++++++++ .../FEVariable_SetMethod@ScalarMethods.F90 | 77 ++++++++ .../FEVariable_SetMethod@VectorMethods.F90 | 94 +++++++++ 8 files changed, 480 insertions(+), 21 deletions(-) create mode 100644 src/modules/FEVariable/src/FEVariable_SetMethod.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 create mode 100644 src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 diff --git a/src/modules/FEVariable/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt index 9e35caea3..2e1b0aede 100644 --- a/src/modules/FEVariable/CMakeLists.txt +++ b/src/modules/FEVariable/CMakeLists.txt @@ -35,5 +35,5 @@ target_sources( ${src_path}/FEVariable_VectorInterpolationMethod.F90 ${src_path}/FEVariable_MatrixInterpolationMethod.F90 ${src_path}/FEVariable_IOMethod.F90 - ${src_path}/FEVariable_MeanMethod.F90) - + ${src_path}/FEVariable_MeanMethod.F90 + ${src_path}/FEVariable_SetMethod.F90) diff --git a/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 index e2b3ee888..cdd07b9e6 100644 --- a/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 @@ -16,13 +16,6 @@ MODULE FEVariable_ConstructorMethod USE BaseType, ONLY: FEVariable_, & - FEVariableScalar_, & - FEVariableVector_, & - FEVariableMatrix_, & - FEVariableConstant_, & - FEVariableSpace_, & - FEVariableTime_, & - FEVariableSpaceTime_, & TypeFEVariableOpt USE GlobalData, ONLY: I4B, DFP, LGT diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index bc1eb2b1f..d889b6f6d 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -15,24 +15,23 @@ ! along with this program. If not, see MODULE FEVariable_Method + USE FEVariable_AdditionMethod +USE FEVariable_ConstructorMethod USE FEVariable_DivisionMethod -USE FEVariable_MultiplicationMethod USE FEVariable_DotProductMethod -USE FEVariable_SubtractionMethod +USE FEVariable_GetMethod +USE FEVariable_IOMethod +USE FEVariable_InterpolationMethod +USE FEVariable_MatrixInterpolationMethod USE FEVariable_MeanMethod -USE FEVariable_UnaryMethod - -USE FEVariable_ConstructorMethod +USE FEVariable_MultiplicationMethod USE FEVariable_NodalVariableMethod USE FEVariable_QuadratureVariableMethod - -USE FEVariable_GetMethod - USE FEVariable_ScalarInterpolationMethod +USE FEVariable_SetMethod +USE FEVariable_SubtractionMethod +USE FEVariable_UnaryMethod USE FEVariable_VectorInterpolationMethod -USE FEVariable_MatrixInterpolationMethod -USE FEVariable_InterpolationMethod -USE FEVariable_IOMethod END MODULE FEVariable_Method diff --git a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 new file mode 100644 index 000000000..d72332631 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 @@ -0,0 +1,179 @@ +! 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 + +!---------------------------------------------------------------------------- +! 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 + +END MODULE FEVariable_SetMethod diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index 32fddf33f..46461d104 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -33,4 +33,7 @@ target_sources( ${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_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_SetMethod@MatrixMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 new file mode 100644 index 000000000..f3541402e --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 @@ -0,0 +1,114 @@ +! 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 + +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 + +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 + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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..39afff6d7 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 @@ -0,0 +1,77 @@ +! 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 +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 +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 + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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..5a03ceac9 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 @@ -0,0 +1,94 @@ +! 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 +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 + +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 + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE VectorMethods From f58be7182311b35cb930ada46fb044c00acd82bc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 11:14:26 +0900 Subject: [PATCH 037/184] Updating FEVariable adding GetRank, GetVarType, GetDefineOn, GetLen, GetTotalShape --- .../FEVariable/src/FEVariable_GetMethod.F90 | 74 ++++++++++++++++++- .../src/FEVariable_GetMethod@Methods.F90 | 51 +++++++++---- .../src/include/vector_space_time.F90 | 1 - 3 files changed, 105 insertions(+), 21 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 index 2bdf9b117..b904400de 100644 --- a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 @@ -32,14 +32,20 @@ MODULE FEVariable_GetMethod PUBLIC :: SIZE PUBLIC :: SHAPE -PUBLIC :: OPERATOR(.RANK.) +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_ @@ -164,6 +170,37 @@ MODULE PURE FUNCTION fevar_Shape(obj) RESULT(ans) END FUNCTION fevar_Shape END INTERFACE Shape +!---------------------------------------------------------------------------- +! 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 !---------------------------------------------------------------------------- @@ -178,7 +215,11 @@ MODULE PURE FUNCTION fevar_rank(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B) :: ans END FUNCTION fevar_rank -END INTERFACE +END INTERFACE OPERATOR(.RANK.) + +INTERFACE GetRank + MODULE PROCEDURE fevar_rank +END INTERFACE GetRank !---------------------------------------------------------------------------- ! vartype@GetMethods @@ -194,7 +235,11 @@ MODULE PURE FUNCTION fevar_vartype(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B) :: ans END FUNCTION fevar_vartype -END INTERFACE +END INTERFACE OPERATOR(.vartype.) + +INTERFACE GetVarType + MODULE PROCEDURE fevar_vartype +END INTERFACE GetVarType !---------------------------------------------------------------------------- ! defineon@GetMethods @@ -210,7 +255,28 @@ MODULE PURE FUNCTION fevar_defineon(obj) RESULT(ans) CLASS(FEVariable_), INTENT(IN) :: obj INTEGER(I4B) :: ans END FUNCTION fevar_defineon -END INTERFACE +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 diff --git a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 index 2c18526da..ffc16a9e8 100644 --- a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 @@ -17,13 +17,20 @@ 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 !---------------------------------------------------------------------------- @@ -35,7 +42,7 @@ ans = "Scalar" CASE (feopt%vector) - ans = "Scalar" + ans = "Vector" CASE (feopt%matrix) ans = "Matrix" @@ -101,7 +108,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Size -IF (PRESENT(dim)) THEN +LOGICAL(LGT) :: isok + +isok = PRESENT(dim) +IF (isok) THEN ans = obj%s(dim) ELSE ans = obj%len @@ -109,42 +119,51 @@ END PROCEDURE fevar_Size !---------------------------------------------------------------------------- -! Shape +! GetTotalShape !---------------------------------------------------------------------------- -MODULE PROCEDURE fevar_Shape +MODULE PROCEDURE fevar_GetTotalShape SELECT CASE (obj%rank) CASE (feopt%scalar) SELECT CASE (obj%vartype) - CASE (feopt%constant) - ans = [1] - CASE (feopt%space, feopt%time) - ans = obj%s(1:1) + CASE (feopt%constant, feopt%space, feopt%time) + ans = 1 CASE (feopt%spaceTime) - ans = obj%s(1:2) + ans = 2 END SELECT CASE (feopt%vector) SELECT CASE (obj%vartype) CASE (feopt%constant) - ans = obj%s(1:1) + ans = 1 CASE (feopt%space, feopt%time) - ans = obj%s(1:2) + ans = 2 CASE (feopt%spaceTime) - ans = obj%s(1:3) + ans = 3 END SELECT CASE (feopt%matrix) SELECT CASE (obj%vartype) CASE (feopt%constant) - ans = obj%s(1:2) + ans = 2 CASE (feopt%space, feopt%time) - ans = obj%s(1:3) + ans = 3 CASE (feopt%spaceTime) - ans = obj%s(1:4) + 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, tsize) +ans(1:tsize) = obj%s(1:tsize) END PROCEDURE fevar_Shape !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90 index fbb4beaa0..20db18d8c 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time.F90 @@ -6,7 +6,6 @@ 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) From 5e406488235c827d493160d2a2eb026669b52249 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 11:14:46 +0900 Subject: [PATCH 038/184] Updating ElemshapeData_InterpolMethods Adding GetInterpolation_ --- .../src/ElemshapeData_InterpolMethods.F90 | 37 +++-- .../ElemshapeData_InterpolMethods@Methods.F90 | 151 +++++++++++------- 2 files changed, 117 insertions(+), 71 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index 24a8e06c6..b8e9aa316 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -23,6 +23,7 @@ MODULE ElemshapeData_InterpolMethods IMPLICIT NONE PRIVATE +PUBLIC :: GetInterpolation_ PUBLIC :: GetInterpolation PUBLIC :: Interpolation @@ -36,16 +37,28 @@ MODULE ElemshapeData_InterpolMethods ! !# 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 +! 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 +! +! - 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 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 ! +! - 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 GetInterpolation MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj @@ -123,16 +136,20 @@ END SUBROUTINE GetInterpolation_1a ! !# 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 +! If ans is not initiated then it will be initiated. If +! ans is initiated then its properties will not be altered. +! +! - 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 ! ! - 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 ! +! - ans will Quadrature and SpaceTime + INTERFACE GetInterpolation MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index d11fee752..9f10658b5 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -16,8 +16,12 @@ ! SUBMODULE(ElemshapeData_InterpolMethods) Methods -USE ReallocateUtility, ONLY: Reallocate -USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ +USE BaseType, ONLY: TypeFEVariableOpt +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_,& + FEVariableInitiate => Initiate, & + FEVariableGetRank => GetRank, & + FEVariableGetTotalShape => GetTotalShape, & + FEVariableSize => Size IMPLICIT NONE CONTAINS @@ -27,35 +31,45 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation1 -! 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, ans=r1, val=val) -! interpol = QuadratureVariable(r1, typeFEVariableScalar, & -! & typeFEVariableSpace) -! DEALLOCATE (r1) -! CASE (Vector) -! CALL getInterpolation(obj=obj, ans=r2, val=val) -! interpol = QuadratureVariable(r2, typeFEVariableVector, & -! & typeFEVariableSpace) -! DEALLOCATE (r2) -! CASE (Matrix) -! CALL getInterpolation(obj=obj, ans=r3, val=val) -! interpol = QuadratureVariable(r3, typeFEVariableMatrix, & -! & typeFEVariableSpace) -! DEALLOCATE (r3) -! END SELECT +INTEGER(I4B) :: s(TypeFEVariableOpt%maxRank), totalShape, myrank, mylen + +IF (ans%isInit) THEN + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +ELSE + + myrank = FEVariableGetRank(val) + totalShape = 0 + + SELECT CASE (myrank) + CASE (TypeFEVariableOpt%scalar) + totalShape = 1 + s(1) = obj%nips + mylen = s(1) + + CASE (TypeFEVariableOpt%vector) + totalShape = 2 + s(1) = FEVariableSize(val, 1) + s(2) = obj%nips + mylen = s(1) * s(2) + + 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) + + END SELECT + + CALL FEVariableInitiate(obj=ans, & + s=s(1:totalShape), & + defineon=TypeFEVariableOpt%quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=FEVariableGetRank(val), & + len=mylen) + + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +END IF END PROCEDURE GetInterpolation1 !---------------------------------------------------------------------------- @@ -96,36 +110,51 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetInterpolation2 -! 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 -! END IF -! !! -! !! if val is a nodal variable then interpolate -! !! -! SELECT CASE (val%rank) -! CASE (Scalar) -! CALL getInterpolation(obj=obj, ans=r2, val=val) -! interpol = QuadratureVariable(r2, typeFEVariableScalar, & -! & typeFEVariableSpaceTime) -! DEALLOCATE (r2) -! CASE (Vector) -! CALL getInterpolation(obj=obj, ans=r3, val=val) -! interpol = QuadratureVariable(r3, typeFEVariableVector, & -! & typeFEVariableSpaceTime) -! DEALLOCATE (r3) -! CASE (Matrix) -! CALL getInterpolation(obj=obj, ans=r4, val=val) -! interpol = QuadratureVariable(r4, typeFEVariableMatrix, & -! & typeFEVariableSpaceTime) -! DEALLOCATE (r4) -! END SELECT -! !! +INTEGER(I4B) :: s(TypeFEVariableOpt%maxRank), totalShape, myrank, mylen, & + nipt + +IF (ans%isInit) THEN + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +ELSE + + myrank = FEVariableGetRank(val) + totalShape = 0 + nipt = SIZE(obj) + + SELECT CASE (myrank) + CASE (TypeFEVariableOpt%scalar) + + totalShape = 2 + s(1) = obj(1)%nips + s(2) = nipt + mylen = s(1) * s(2) + + 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) + + 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 SELECT + + CALL FEVariableInitiate(obj=ans, & + s=s(1:totalShape), & + defineon=TypeFEVariableOpt%quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=FEVariableGetRank(val), & + len=mylen) + + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +END IF END PROCEDURE GetInterpolation2 !---------------------------------------------------------------------------- From d8edc2fa891b7493967d64d0363acfba046a0d95 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 11:28:32 +0900 Subject: [PATCH 039/184] Updating ElemshapeData_ConstructorMethods Minor updates --- .../src/ElemshapeData_ConstructorMethods.F90 | 33 +++++---- ...emshapeData_ConstructorMethods@Methods.F90 | 73 +++++++++---------- 2 files changed, 53 insertions(+), 53 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 index 48406b880..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, nnt) + 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 @@ -53,9 +54,13 @@ MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips, nnt) !! number of integration points INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnt !! it is used when elemshape data is STElemShapeData - END SUBROUTINE elemsd_Allocate + END SUBROUTINE obj_Allocate END INTERFACE ALLOCATE +INTERFACE Initiate + MODULE PROCEDURE obj_Allocate +END INTERFACE Initiate + !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -65,8 +70,8 @@ END SUBROUTINE elemsd_Allocate ! 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 @@ -77,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 !---------------------------------------------------------------------------- @@ -89,14 +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) + MODULE SUBROUTINE obj_Initiate2(obj1, obj2) CLASS(ElemshapeData_), INTENT(INOUT) :: obj1 CLASS(ElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_Initiate2 + END SUBROUTINE obj_Initiate2 END INTERFACE Initiate INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_Initiate2 + MODULE PROCEDURE obj_Initiate2 END INTERFACE !---------------------------------------------------------------------------- @@ -125,11 +130,11 @@ END SUBROUTINE elemsd_Initiate2 ! 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 !---------------------------------------------------------------------------- @@ -147,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/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 index 9c8f20e39..b442e106f 100755 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 @@ -20,10 +20,9 @@ ! summary: Constructor method for ElemshapeData_ and STElemshapeData_ SUBMODULE(ElemshapeData_ConstructorMethods) Methods +USE GlobalData, ONLY: stderr USE ReallocateUtility, ONLY: Reallocate - USE QuadraturePoint_Method, ONLY: GetQuadraturePoints - USE ErrorHandling, ONLY: Errormsg IMPLICIT NONE @@ -33,12 +32,12 @@ ! Initiate !---------------------------------------------------------------------------- -MODULE 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%normal, 3, nips) CALL Reallocate(obj%dNdXt, nns, nsd, nips) CALL Reallocate(obj%jacobian, nsd, xidim, nips) CALL Reallocate(obj%js, nips) @@ -52,41 +51,32 @@ obj%nns = nns isok = PRESENT(nnt) - -IF (isok) THEN - SELECT TYPE (obj); TYPE is (STElemShapeData_) - obj%nnt = nnt - - CALL Reallocate(obj%T, nnt) - CALL Reallocate(obj%dTdTheta, nnt) - CALL Reallocate(obj%dNTdt, nns, nnt, nips) - CALL Reallocate(obj%dNTdXt, nns, nnt, nsd, nips) - - END SELECT -END IF - -END PROCEDURE elemsd_Allocate +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 -END PROCEDURE elemsd_Initiate1 +END PROCEDURE obj_Initiate1 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_Initiate2 +MODULE PROCEDURE obj_Initiate2 INTEGER(I4B) :: ii, jj, kk, nns, nsd, xidim, nips, nnt, ll, nnt nns = obj2%nns @@ -98,8 +88,8 @@ nnt = obj2%nnt END SELECT -CALL elemsd_Allocate(obj=obj1, nsd=nsd, xidim=xidim, nns=nns, & - nips=nips, nnt=nnt) +CALL obj_Allocate(obj=obj1, nsd=nsd, xidim=xidim, nns=nns, & + nips=nips, nnt=nnt) DO CONCURRENT(jj=1:nips, ii=1:nns) obj1%N(ii, jj) = obj2%N(ii, jj) @@ -128,7 +118,7 @@ SELECT TYPE (obj1); TYPE is (STElemShapeData_) SELECT TYPE (obj2); TYPE is (STElemShapeData_) obj1%wt = obj2%wt -! obj1%theta = obj2%theta + ! obj1%theta = obj2%theta obj1%jt = obj2%jt obj1%nnt = obj2%nnt nnt = obj1%nnt @@ -149,21 +139,26 @@ END SELECT END SELECT -END PROCEDURE elemsd_Initiate2 +END PROCEDURE obj_Initiate2 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE stsd_Initiate -INTEGER(I4B) :: tip, ip, nnt +MODULE PROCEDURE obj_Initiate3 +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tip, ip, nnt, tsize tip = elemsd%nips -IF (ALLOCATED(obj)) THEN - DO ip = 1, SIZE(obj) +isok = ALLOCATED(obj) +IF (isok) THEN + tsize = SIZE(obj) + + DO ip = 1, tsize CALL DEALLOCATE (obj(ip)) END DO + DEALLOCATE (obj) END IF @@ -183,13 +178,13 @@ 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 +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) @@ -216,7 +211,7 @@ IF (ALLOCATED(obj%dNTdt)) DEALLOCATE (obj%dNTdt) IF (ALLOCATED(obj%dNTdXt)) DEALLOCATE (obj%dNTdXt) END SELECT -END PROCEDURE elemsd_Deallocate +END PROCEDURE obj_Deallocate !---------------------------------------------------------------------------- ! From a7c08a74f33323259adb9f18480283aa067cb28e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 15:34:03 +0900 Subject: [PATCH 040/184] Updating FEVariable_ScalarInterpolation updating FEVariable_ScalarInterpolation GetInterpolation_ --- .../FEVariable_ScalarInterpolationMethod.F90 | 111 ++++++++++++++++ ...able_ScalarInterpolationMethod@Methods.F90 | 125 +++++++++++++++--- 2 files changed, 220 insertions(+), 16 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 index 6db231a1a..fbbfd61d4 100644 --- a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 @@ -103,6 +103,42 @@ MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_2(obj, rank, vartype, & 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 !---------------------------------------------------------------------------- @@ -179,6 +215,40 @@ END SUBROUTINE ScalarSpaceGetInterpolation_2 ! 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 @@ -273,6 +343,47 @@ MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_2(obj, rank, & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 index 25a1d86c5..02f0f0b65 100644 --- a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 @@ -50,12 +50,21 @@ 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 MasterGetInterpolation_(ans, scale, N, nns, nips, val, & - valStart, ansStart) +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(:, :) @@ -72,7 +81,27 @@ PURE SUBROUTINE MasterGetInterpolation_(ans, scale, N, nns, nips, val, & END DO END DO -END SUBROUTINE MasterGetInterpolation_ +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_ @@ -89,9 +118,9 @@ END SUBROUTINE MasterGetInterpolation_ !! convert nodal values to quadrature values by using N !! make sure nns .LE. obj%len - CALL MasterGetInterpolation_(ans=ans, scale=scale, N=N, nns=nns, & - nips=nips, val=obj%val, valStart=0, & - ansStart=0) + 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 @@ -119,9 +148,9 @@ END SUBROUTINE MasterGetInterpolation_ SELECT CASE (obj%varType) CASE (TypeFEVariableOpt%nodal) - CALL MasterGetInterpolation_(ans=ans%val, scale=scale, N=N, & - nns=nns, nips=nips, val=obj%val, & - valStart=valStart, ansStart=ansStart) + CALL MasterGetInterpolation1_(ans=ans%val, scale=scale, N=N, & + nns=nns, nips=nips, val=obj%val, & + valStart=valStart, ansStart=ansStart) CASE (TypeFEVariableOpt%quadrature) DO ips = 1, nips @@ -132,6 +161,31 @@ END SUBROUTINE MasterGetInterpolation_ END PROCEDURE ScalarSpaceGetInterpolation_2 +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%vartype is nodal +! convert nodal values to quadrature values by using N +! make sure nns .LE. obj%len +! +! obj%vartype 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%vartype) +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_ !---------------------------------------------------------------------------- @@ -156,9 +210,9 @@ END SUBROUTINE MasterGetInterpolation_ DO aa = 1, nnt myscale = scale * T(aa) valStart = (aa - 1) * obj%s(1) - CALL MasterGetInterpolation_(ans=ans, scale=myscale, N=N, nns=nns, & - nips=nips, val=obj%val, valStart=valStart, & - ansStart=ansStart) + CALL MasterGetInterpolation1_(ans=ans, scale=myscale, N=N, nns=nns, & + nips=nips, val=obj%val, valStart=valStart, & + ansStart=ansStart) END DO CASE (TypeFEVariableOpt%quadrature) @@ -184,7 +238,7 @@ END SUBROUTINE MasterGetInterpolation_ LOGICAL(LGT), PARAMETER :: yes = .TRUE. ansStart = (timeIndx - 1) * ans%s(1) -IF (.NOT. addContribution) ans%val(1+ansStart:nips+ansStart) = 0.0_DFP +IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP SELECT CASE (obj%varType) @@ -192,9 +246,9 @@ END SUBROUTINE MasterGetInterpolation_ DO aa = 1, nnt myscale = scale * T(aa) valStart = (aa - 1) * obj%s(1) - CALL MasterGetInterpolation_(ans=ans%val, scale=myscale, N=N, nns=nns, & - nips=nips, val=obj%val, valStart=valStart, & - ansStart=ansStart) + 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) @@ -208,4 +262,43 @@ END SUBROUTINE MasterGetInterpolation_ END PROCEDURE ScalarSpaceTimeGetInterpolation_2 +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%vartype 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%vartype 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%varType) + +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 + END SUBMODULE Methods From ca0c3678d98f493dc395c59ccdbe98e4995bf6d6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 15:34:25 +0900 Subject: [PATCH 041/184] Updating ElemshapeData_ScalarInterpolation adding GetInterpolation_ --- .../ElemshapeData_ScalarInterpolMethods.F90 | 23 ++++++++++ ...hapeData_ScalarInterpolMethods@Methods.F90 | 42 +++++++++++++++++++ 2 files changed, 65 insertions(+) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 index 2fbb97278..4c967af73 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 @@ -305,6 +305,29 @@ MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, tsize, & 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 index 9b698f879..fb0c34c1d 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 @@ -212,6 +212,48 @@ 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 !---------------------------------------------------------------------------- From 36c584547a8a5d3780802430026ca67dbf2644f3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 15:34:45 +0900 Subject: [PATCH 042/184] updating ForceVector adding ForceVector methods --- .../ForceVector/src/ForceVector_Method.F90 | 203 +++++++++++++++++- .../src/ForceVector_Method@Methods.F90 | 75 +++++-- 2 files changed, 260 insertions(+), 18 deletions(-) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index c9996e544..71595e7ed 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -47,6 +47,30 @@ MODULE PURE FUNCTION ForceVector1(test) RESULT(ans) END FUNCTION 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 ForceVector_ + MODULE PURE 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 ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -70,6 +94,31 @@ MODULE PURE FUNCTION ForceVector2(test, c, crank) RESULT(ans) END FUNCTION ForceVector2 END INTERFACE ForceVector +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega} c N^{I} d\Omega +! $$ + +INTERFACE ForceVector_ + MODULE PURE 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), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_2 +END INTERFACE ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -95,6 +144,32 @@ MODULE PURE FUNCTION ForceVector3(test, c, crank) RESULT(ans) END FUNCTION 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 ForceVector_ + MODULE PURE 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 ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -120,6 +195,33 @@ MODULE PURE FUNCTION ForceVector4(test, c, crank) RESULT(ans) END FUNCTION 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 ForceVector_ + MODULE PURE 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 ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -149,7 +251,7 @@ END FUNCTION ForceVector5 END INTERFACE ForceVector !---------------------------------------------------------------------------- -! ForceVector +! ForceVector_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -158,12 +260,33 @@ END FUNCTION ForceVector5 ! !# Introduction ! -! This routine computes the following integral. +! This routine computes the following integral ! ! $$ -! +! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega ! $$ +INTERFACE ForceVector_ + MODULE PURE 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 ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + INTERFACE ForceVector MODULE PURE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) & RESULT(ans) @@ -180,6 +303,27 @@ END FUNCTION ForceVector6 ! ForceVector !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE ForceVector_ + MODULE PURE 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 ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector @@ -208,6 +352,35 @@ END FUNCTION ForceVector7 ! 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 ForceVector_ + MODULE PURE 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 ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector @@ -227,4 +400,28 @@ MODULE PURE FUNCTION ForceVector8(test, c) RESULT(ans) END FUNCTION 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 ForceVector_ + MODULE PURE 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 ForceVector_ + END MODULE ForceVector_Method diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index f72cb7f69..9fbd44e8a 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,11 +14,10 @@ ! ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -! SUBMODULE(ForceVector_Method) Methods USE ReallocateUtility, ONLY: Reallocate -USE ElemshapeData_Method, ONLY: GetInterpolation +USE ElemshapeData_Method, ONLY: GetInterpolation, GetInterpolation_ USE ProductUtility, ONLY: OuterProd IMPLICIT NONE CONTAINS @@ -27,40 +27,63 @@ !---------------------------------------------------------------------------- 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) :: realval INTEGER(I4B) :: ips ! main -CALL Reallocate(ans, test%nns) +tsize = test%nns DO ips = 1, test%nips realval = test%js(ips) * test%ws(ips) * test%thickness(ips) - ans(1:test%nns) = ans(1:test%nns) + realval * test%N(1:test%nns, ips) + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO -END PROCEDURE ForceVector1 +END PROCEDURE ForceVector_1 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector2 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) +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 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +REAL(DFP) :: realval INTEGER(I4B) :: ips -! main -CALL GetInterpolation(obj=test, ans=realval, val=c) -realval = test%js * test%ws * test%thickness * realval -CALL Reallocate(ans, SIZE(test%N, 1)) +tsize = test%nns +! CALL Reallocate(ans, SIZE(test%N, 1)) DO ips = 1, test%nips - ans = ans + realval(ips) * test%N(1:test%nns, ips) + CALL GetInterpolation_(obj=test, ans=realval, val=c, scale=one, & + addContribution=no, timeIndx=1, spaceIndx=ips) + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * realval + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO -DEALLOCATE (realval) -END PROCEDURE ForceVector2 +END PROCEDURE ForceVector_2 !---------------------------------------------------------------------------- ! ForceVector @@ -88,6 +111,28 @@ ! ForceVector !---------------------------------------------------------------------------- +MODULE PROCEDURE ForceVector_3 +! ! Define internal variable +! REAL(DFP), ALLOCATABLE :: realval(:) +! REAL(DFP), ALLOCATABLE :: cbar(:, :) +! INTEGER(I4B) :: ips +! +! ! main +! CALL GetInterpolation(obj=test, ans=cbar, val=c) +! realval = test%js * test%ws * test%thickness +! CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) +! +! DO ips = 1, SIZE(realval) +! ans = ans + realval(ips) * OuterProd(cbar(:, ips), test%N(:, ips)) +! END DO +! +! DEALLOCATE (realval, cbar) +END PROCEDURE ForceVector_3 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + MODULE PROCEDURE ForceVector4 ! Define internal variable REAL(DFP), ALLOCATABLE :: realval(:) From 53f20d2aec18270f27338e93e4c4f6518be56cdb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 16:59:07 +0900 Subject: [PATCH 043/184] updating FEVariable_VectorIntertpolationMethod Adding GetInterpolation_ method --- .../FEVariable_VectorInterpolationMethod.F90 | 116 ++++++++ ...able_VectorInterpolationMethod@Methods.F90 | 252 ++++++++++++++---- 2 files changed, 318 insertions(+), 50 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 index b17870538..89477018f 100644 --- a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 @@ -108,6 +108,43 @@ MODULE PURE SUBROUTINE VectorConstantGetInterpolation_2(obj, rank, vartype, & 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 !---------------------------------------------------------------------------- @@ -184,6 +221,43 @@ END SUBROUTINE VectorSpaceGetInterpolation_2 ! 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 @@ -280,6 +354,48 @@ MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_2(obj, rank, & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 index 908bad4de..4ad22fc2f 100644 --- a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 @@ -20,47 +20,12 @@ IMPLICIT NONE CONTAINS -!---------------------------------------------------------------------------- -! 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 - !---------------------------------------------------------------------------- ! MasterGetInterpolation_ !---------------------------------------------------------------------------- PURE SUBROUTINE MasterGetInterpolationFromNodal1_(ans, scale, N, nns, nsd, & - nips, val, valStart, valEnd) + nips, val, valStart, valEnd) REAL(DFP), INTENT(INOUT) :: ans(:, :) REAL(DFP), INTENT(IN) :: scale REAL(DFP), INTENT(IN) :: N(:, :) @@ -124,9 +89,37 @@ 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) + nips, val, valStart, & + valEnd) REAL(DFP), INTENT(INOUT) :: ans(:, :) REAL(DFP), INTENT(IN) :: scale INTEGER(I4B), INTENT(IN) :: nsd, nips @@ -174,6 +167,74 @@ PURE SUBROUTINE MasterGetInterpolationFromQuadrature2_(ans, scale, nsd, & 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_ !---------------------------------------------------------------------------- @@ -192,17 +253,17 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ !! 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) + 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) + nsd=nrow, nips=nips, & + val=obj%val, valStart=0, & + valEnd=valEnd) END SELECT @@ -250,6 +311,44 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ ! GetInterpolation_ !---------------------------------------------------------------------------- +! obj%vartype is nodal +! +! Nodal Vector Space +! Convert nodal values to quadrature values by using N(:,:) +! make sure nns .LE. obj%len +! +! obj%vartype 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%varType) +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 @@ -272,9 +371,9 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ 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) + nns=nns, nsd=nrow, nips=nips, & + val=obj%val, valStart=valStart, & + valEnd=valEnd) END DO CASE (TypeFEVariableOpt%quadrature) @@ -283,10 +382,10 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ valStart = nips * nrow * (timeIndx - 1) CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, & - nsd=nrow, nips=nips, & - val=obj%val, & - valStart=valStart, & - valEnd=valEnd) + nsd=nrow, nips=nips, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd) END SELECT @@ -343,4 +442,57 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ END PROCEDURE VectorSpaceTimeGetInterpolation_2 +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! 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 ans +! obj%s(2) should be atleast nns +! obj%s(3) should be atleast nnt +! +! obj%vartype 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%varType) +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 + END SUBMODULE Methods From 5311a3a50c4479b1012674deb4db8e6e90494657 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Sep 2025 16:59:38 +0900 Subject: [PATCH 044/184] Updating ElemshapeData_VectorInterpolationMethods adding GetInterpolation_ --- .../ElemshapeData_VectorInterpolMethods.F90 | 22 +++++++++ ...hapeData_VectorInterpolMethods@Methods.F90 | 45 +++++++++++++++++++ 2 files changed, 67 insertions(+) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 index b3dd75df5..625b58020 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 @@ -282,6 +282,28 @@ MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, nrow, ncol, & 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 index 7a2a3d5bf..daa1354f3 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 @@ -248,6 +248,51 @@ ! 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 From 4ba5de5c2209d969d85f0cbb0fce9f642220c8f7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 07:04:17 +0900 Subject: [PATCH 045/184] Updating FEVariable_MatrixInterpolationMethod adding matrix interpolation methods --- .../FEVariable_MatrixInterpolationMethod.F90 | 117 ++++++++++ ...able_MatrixInterpolationMethod@Methods.F90 | 215 ++++++++++++++++-- 2 files changed, 310 insertions(+), 22 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 index 6e07fb2dc..42de8f9de 100644 --- a/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 @@ -103,6 +103,42 @@ MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_2(obj, rank, vartype, & 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 !---------------------------------------------------------------------------- @@ -179,6 +215,43 @@ END SUBROUTINE MatrixSpaceGetInterpolation_2 ! 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 @@ -261,6 +334,50 @@ MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_2(obj, rank, & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 index 58c52f777..111b39b9d 100644 --- a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 @@ -14,7 +14,6 @@ ! ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -! SUBMODULE(FEVariable_MatrixInterpolationMethod) Methods IMPLICIT NONE @@ -25,7 +24,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE MatrixConstantGetInterpolation_1 -INTEGER(I4B) :: ips, jj, istart, iend +INTEGER(I4B) :: ips, ii, jj, indx dim1 = obj%s(1) dim2 = obj%s(2) @@ -35,10 +34,10 @@ DO ips = 1, dim3 DO jj = 1, dim2 - istart = (jj - 1) * dim1 + 1 - iend = jj * dim1 - ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & - + scale * obj%val(istart:iend) + 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 @@ -55,13 +54,32 @@ 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_ !---------------------------------------------------------------------------- @@ -77,19 +95,28 @@ PURE SUBROUTINE MasterGetInterpolationFromNodal1_(ans, scale, N, nns, dim1, & INTEGER(I4B), INTENT(IN) :: valStart INTEGER(I4B), INTENT(OUT) :: valEnd - INTEGER(I4B) :: ips, jj, istart, iend + INTEGER(I4B) :: ips, ii, jj, inode, tsize, indx, a, b + + tsize = dim1 * dim2 DO ips = 1, nips - DO jj = 1, dim2 - istart = (jj - 1) * dim1 + 1 + valStart - iend = jj * dim1 + valStart - ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) & - + scale * N(jj, ips) * val(istart:iend) + 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 * dim1 * dim2 - + valEnd = valStart + nns * tsize END SUBROUTINE MasterGetInterpolationFromNodal1_ !---------------------------------------------------------------------------- @@ -128,13 +155,49 @@ PURE SUBROUTINE MasterGetInterpolationFromNodal2_(ans, scale, N, nns, dim1, & 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) @@ -145,18 +208,25 @@ PURE SUBROUTINE MasterGetInterpolationFromQuadrature1_(ans, scale, dim1, & INTEGER(I4B), INTENT(IN) :: valStart INTEGER(I4B), INTENT(OUT) :: valEnd - INTEGER(I4B) :: ips, istart, iend, jj + INTEGER(I4B) :: ips, ii, jj, tsize, indx, a, b + + tsize = dim1 * dim2 DO ips = 1, nips + a = (ips - 1) * tsize + DO jj = 1, dim2 - istart = (jj - 1) * dim1 + 1 + valStart - iend = jj * dim1 + valStart - ans(1:dim1, jj, ips) = ans(1:dim1, jj, ips) + scale * val(istart:iend) + 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 * dim1 * dim2 - + valEnd = valStart + nips * tsize END SUBROUTINE MasterGetInterpolationFromQuadrature1_ !---------------------------------------------------------------------------- @@ -187,6 +257,37 @@ PURE SUBROUTINE MasterGetInterpolationFromQuadrature2_(ans, scale, dim1, & 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_ !---------------------------------------------------------------------------- @@ -270,6 +371,37 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ ! 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%varType) +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 @@ -361,6 +493,45 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature2_ 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%varType) +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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 806579ae6af1eb4d4206e5f79aa8c04cd9dd524f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 07:04:34 +0900 Subject: [PATCH 046/184] updating ElemshapeData_MatrixInterpolation GetInterpolation --- .../ElemshapeData_MatrixInterpolMethods.F90 | 29 +++++++++++-- ...hapeData_MatrixInterpolMethods@Methods.F90 | 43 +++++++++++++++++++ 2 files changed, 69 insertions(+), 3 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 index 936ae9780..e8b867966 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 @@ -265,9 +265,9 @@ END SUBROUTINE GetInterpolation_4 ! GetInterpolation@Methods !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation +!> 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, & @@ -287,6 +287,29 @@ END SUBROUTINE GetInterpolation_4a ! 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(:) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 index 30069bfdc..a8f653f24 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 @@ -268,6 +268,49 @@ 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 !---------------------------------------------------------------------------- From 8038c11a0b29d4b239be5775ba5bbfec07d95116 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 08:40:49 +0900 Subject: [PATCH 047/184] Updating ProductUtility adding Outerprod_ --- src/modules/Utility/src/ProductUtility.F90 | 31 +++++++++++++++++++ .../Utility/src/ProductUtility@Methods.F90 | 16 ++++++++++ 2 files changed, 47 insertions(+) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index b076bf7ea..599f76a6c 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -124,6 +124,10 @@ MODULE PURE FUNCTION OuterProd_r1r1(a, b) RESULT(ans) END FUNCTION OuterProd_r1r1 END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_@ProductMethods +!---------------------------------------------------------------------------- + INTERFACE OuterProd_ MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, & ncol) @@ -163,6 +167,10 @@ MODULE PURE FUNCTION OuterProd_r1r1s(a, b, sym) RESULT(ans) END FUNCTION OuterProd_r1r1s END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_@ProductMethods +!---------------------------------------------------------------------------- + INTERFACE OuterProd_ MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, & nrow, ncol) @@ -193,6 +201,10 @@ MODULE PURE FUNCTION OuterProd_r1r2(a, b) RESULT(ans) END FUNCTION OuterProd_r1r2 END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_@ProductMethods +!---------------------------------------------------------------------------- + !> author: Shion Shimizu ! date: 2025-03-05 ! summary: a x b @@ -281,6 +293,25 @@ MODULE PURE FUNCTION OuterProd_r2r1(a, b) RESULT(ans) END FUNCTION OuterProd_r2r1 END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_@ProductMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-04 +! summary: a x b + +INTERFACE OuterProd_ + 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 OuterProd_ + !---------------------------------------------------------------------------- ! OuterProd@ProductMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 2ec17697f..d11862d72 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -227,6 +227,22 @@ ! !---------------------------------------------------------------------------- +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 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 2) From 2c71580c41b2e8f305a73663504fd91030968feb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 08:41:05 +0900 Subject: [PATCH 048/184] updating ForceVector adding ForceVector and ForceVector_ --- .../ForceVector/src/ForceVector_Method.F90 | 6 +- .../src/ForceVector_Method@Methods.F90 | 314 +++++++++++++----- 2 files changed, 241 insertions(+), 79 deletions(-) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 71595e7ed..66e2d76f9 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -132,7 +132,7 @@ END SUBROUTINE 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 @@ -183,7 +183,7 @@ END SUBROUTINE 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 @@ -263,7 +263,7 @@ END FUNCTION ForceVector5 ! This routine computes the following integral ! ! $$ -! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega +! F_{I}=\int_{\Omega}c_{1}c_{2}N^{I}d\Omega ! $$ INTERFACE ForceVector_ diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index 9fbd44e8a..0fc559225 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -18,7 +18,9 @@ SUBMODULE(ForceVector_Method) Methods USE ReallocateUtility, ONLY: Reallocate USE ElemshapeData_Method, ONLY: GetInterpolation, GetInterpolation_ -USE ProductUtility, ONLY: OuterProd +USE ProductUtility, ONLY: OuterProd, OuterProd_ +USE FEVariable_Method, ONLY: FEVariableSize => Size + IMPLICIT NONE CONTAINS @@ -63,7 +65,7 @@ END PROCEDURE ForceVector2 !---------------------------------------------------------------------------- -! ForceVector +! ForceVector_ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector_2 @@ -74,7 +76,6 @@ INTEGER(I4B) :: ips tsize = test%nns -! CALL Reallocate(ans, SIZE(test%N, 1)) DO ips = 1, test%nips CALL GetInterpolation_(obj=test, ans=realval, val=c, scale=one, & @@ -90,43 +91,63 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector3 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, ans=cbar, val=c) -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OuterProd(cbar(:, ips), test%N(:, ips)) -END DO +INTEGER(I4B) :: nrow, ncol -DEALLOCATE (realval, cbar) +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 +! ForceVector_ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector_3 -! ! Define internal variable -! REAL(DFP), ALLOCATABLE :: realval(:) -! REAL(DFP), ALLOCATABLE :: cbar(:, :) -! INTEGER(I4B) :: ips -! -! ! main -! CALL GetInterpolation(obj=test, ans=cbar, val=c) -! realval = test%js * test%ws * test%thickness -! CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) -! -! DO ips = 1, SIZE(realval) -! ans = ans + realval(ips) * OuterProd(cbar(:, ips), test%N(:, ips)) -! END DO -! -! DEALLOCATE (realval, cbar) +! Define internal variable +REAL(DFP) :: realval, cbar3(3) +INTEGER(I4B) :: ips, tsize +REAL(DFP), ALLOCATABLE :: cbar(:) +LOGICAL(LGT) :: isok + +nrow = FEVariableSize(c, 1) +ncol = test%nns +ans(1:nrow, 1:ncol) = 0.0_DFP + +isok = nrow .GT. 3_I4B +IF (isok) THEN + + ALLOCATE (cbar(nrow)) + DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) + CALL GetInterpolation_(obj=test, val=c, ans=cbar, tsize=tsize, & + scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL OuterProd_(a=cbar(1:tsize), b=test%N(1:test%nns, ips), & + anscoeff=1.0_DFP, scale=realval, & + ans=ans, nrow=nrow, ncol=ncol) + END DO + + DEALLOCATE (cbar) + +ELSE + + DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) + CALL GetInterpolation_(obj=test, val=c, ans=cbar3, tsize=tsize, & + scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL OuterProd_(a=cbar3(1:tsize), b=test%N(1:test%nns, ips), & + anscoeff=1.0_DFP, scale=realval, & + ans=ans, nrow=nrow, ncol=ncol) + END DO + +END IF + END PROCEDURE ForceVector_3 !---------------------------------------------------------------------------- @@ -134,46 +155,86 @@ !---------------------------------------------------------------------------- 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_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_4 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -INTEGER(I4B) :: ips +REAL(DFP), ALLOCATABLE :: cbar(:, :) +REAL(DFP) :: realval +INTEGER(I4B) :: ips, ic, jc ! main -CALL GetInterpolation(obj=test, ans=cbar, val=c) -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), SIZE(test%N, 1)) +ic = FEVariableSize(c, 1) +jc = FEVariableSize(c, 2) +dim3 = test%nns +ans(1:ic, 1:jc, 1:dim3) = 0.0_DFP -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OuterProd(cbar(:, :, ips), test%N(:, ips)) +ALLOCATE (cbar(ic, jc)) + +DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) + CALL GetInterpolation_(obj=test, val=c, ans=cbar, nrow=ic, & + ncol=jc, scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL OuterProd_(a=cbar(1:ic, 1:jc), b=test%N(1:test%nns, ips), & + anscoeff=1.0_DFP, scale=realval, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) END DO -DEALLOCATE (realval, cbar) -END PROCEDURE ForceVector4 +DEALLOCATE (cbar) +END PROCEDURE ForceVector_4 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector5 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:) +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 INTEGER(I4B) :: ips ! main -CALL GetInterpolation(obj=test, ans=c1bar, val=c1) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar * c2bar -CALL Reallocate(ans, SIZE(test%N, 1)) +tsize = test%nns -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) +DO ips = 1, test%nips + CALL GetInterpolation_(obj=test, ans=c1bar, val=c1, & + scale=1.0_DFP, addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL GetInterpolation_(obj=test, ans=c2bar, val=c2, & + scale=1.0_DFP, addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=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 -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector5 +END PROCEDURE ForceVector_5 !---------------------------------------------------------------------------- ! ForceVector @@ -199,49 +260,150 @@ DEALLOCATE (realval, c1bar, c2bar) END PROCEDURE ForceVector6 +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_6 +! Define internal variable +REAL(DFP), ALLOCATABLE :: c2bar(:) +REAL(DFP) :: c1bar, realval, c2bar3(3) +INTEGER(I4B) :: ips, tsize +LOGICAL(LGT) :: isok + +nrow = FEVariableSize(c2, 1) +ncol = test%nns +ans(1:nrow, 1:ncol) = 0.0_DFP + +isok = nrow .GT. 3_I4B + +IF (isok) THEN + ALLOCATE (c2bar(nrow)) + DO ips = 1, test%nips + CALL GetInterpolation_(obj=test, val=c2, ans=c2bar, tsize=tsize, & + scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL GetInterpolation_(obj=test, val=c1, ans=c1bar, & + scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c1bar + + CALL OuterProd_(a=c2bar(1:tsize), b=test%N(1:test%nns, ips), & + anscoeff=1.0_DFP, scale=realval, & + ans=ans, nrow=nrow, ncol=ncol) + END DO + + DEALLOCATE (c2bar) + +ELSE + + DO ips = 1, test%nips + CALL GetInterpolation_(obj=test, val=c2, ans=c2bar3, tsize=tsize, & + scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL GetInterpolation_(obj=test, val=c1, ans=c1bar, & + scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c1bar + + CALL OuterProd_(a=c2bar3(1:tsize), b=test%N(1:test%nns, ips), & + anscoeff=1.0_DFP, scale=realval, & + ans=ans, nrow=nrow, ncol=ncol) + END DO + +END IF + +END PROCEDURE ForceVector_6 + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- 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 :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -INTEGER(I4B) :: ips +REAL(DFP), ALLOCATABLE :: c2bar(:, :) +REAL(DFP) :: realval, c1bar +INTEGER(I4B) :: ips, ic, jc ! main -CALL GetInterpolation(obj=test, ans=c1bar, val=c1) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test%N, 1)) +ic = FEVariableSize(c2, 1) +jc = FEVariableSize(c2, 2) +dim3 = test%nns +ans(1:ic, 1:jc, 1:dim3) = 0.0_DFP -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, :, ips), test%N(:, ips)) +ALLOCATE (c2bar(ic, jc)) + +DO ips = 1, test%nips + CALL GetInterpolation_(obj=test, val=c2, ans=c2bar, nrow=ic, & + ncol=jc, scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + CALL GetInterpolation_(obj=test, val=c1, ans=c1bar, scale=1.0_DFP, & + addContribution=.FALSE., & + timeIndx=1_I4B, spaceIndx=ips) + + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c1bar + + CALL OuterProd_(a=c2bar(1:ic, 1:jc), b=test%N(1:test%nns, ips), & + anscoeff=1.0_DFP, scale=realval, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) END DO -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector7 +DEALLOCATE (c2bar) +END PROCEDURE ForceVector_7 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- 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(:) INTEGER(I4B) :: ips +REAL(DFP) :: realval -realval = test%js * test%ws * test%thickness * c -CALL Reallocate(ans, SIZE(test%N, 1)) +tsize = test%nns -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) - -END PROCEDURE ForceVector8 +END PROCEDURE ForceVector_8 !---------------------------------------------------------------------------- ! From 9ce2e36f76cc8344b404e20a3af9aec3f5dcc2ed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 12:30:58 +0900 Subject: [PATCH 049/184] Updating ForceVector_Method making ForceVector_ public --- src/modules/ForceVector/src/ForceVector_Method.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 66e2d76f9..cdd696190 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -23,6 +23,7 @@ MODULE ForceVector_Method PRIVATE PUBLIC :: ForceVector +public :: ForceVector_ !---------------------------------------------------------------------------- ! ForceVector From c5f81ea87184229e018e5ca0689820ce875e877c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 16:11:22 +0900 Subject: [PATCH 050/184] updating FEVariable_ConstructorMethod fixing a bug in Initiate method --- .../FEVariable_ConstructorMethod@Methods.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 index 51ced1a2e..57108edc4 100644 --- a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 @@ -49,17 +49,17 @@ obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len isok = ALLOCATED(obj%val) -IF (isok) THEN - 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 +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 From 5d426cc9a3a8910714ca8cde71dc0b95bebf3cfc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 4 Sep 2025 16:11:49 +0900 Subject: [PATCH 051/184] Updating ElemshapeData_Lagrange@Methods.F90 --- .../ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 index ad274c688..711b620f6 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 @@ -77,7 +77,8 @@ 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, & + layout="VEFC", xij=refelemCoord(1:xidim, :), & + alpha=alpha, beta=beta, & lambda=lambda, ans=xij, nrow=indx(1), ncol=indx(2)) IF (PRESENT(coeff)) THEN From 36f76fa191643685b52684fe200930f28303e027 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 5 Sep 2025 12:25:48 +0900 Subject: [PATCH 052/184] Adding GetTotalQuadraturePoints method adding GetTotalQuadraturePoints method to QuadraturePoint_Method --- .../src/QuadraturePoint_Method.F90 | 58 ++++- ...draturePoint_Method@ConstructorMethods.F90 | 224 ++++++++++++------ .../src/QuadraturePoint_Method@GetMethods.F90 | 51 +++- 3 files changed, 245 insertions(+), 88 deletions(-) diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 1f23017ac..8c3087ca4 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -325,8 +325,10 @@ END SUBROUTINE obj_Initiate6 INTERFACE Initiate MODULE SUBROUTINE obj_Initiate7(obj, refElem, p, q, r, quadratureType1, & - quadratureType2, quadratureType3, alpha1, beta1, lambda1, alpha2, & - beta2, lambda2, alpha3, beta3, lambda3) + 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 @@ -365,8 +367,10 @@ END SUBROUTINE obj_Initiate7 INTERFACE Initiate MODULE SUBROUTINE obj_Initiate8(obj, refElem, nipsx, nipsy, nipsz, & - quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & - lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3) + 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 @@ -489,8 +493,10 @@ END SUBROUTINE obj_Initiate10 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) + 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 @@ -528,8 +534,10 @@ END SUBROUTINE obj_Initiate11 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) + 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 @@ -632,12 +640,42 @@ END FUNCTION obj_Size ! summary: This routine returns total number of quadrature points INTERFACE GetTotalQuadraturepoints - MODULE PURE FUNCTION obj_GetTotalQuadraturePoints(obj) RESULT(ans) + MODULE PURE FUNCTION obj_GetTotalQuadraturePoints1(obj) RESULT(ans) TYPE(QuadraturePoint_), INTENT(IN) :: obj INTEGER(I4B) :: ans - END FUNCTION obj_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 !---------------------------------------------------------------------------- diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index e4ca4a758..93cb47ddd 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -108,24 +108,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_QuadratureNumber1 -INTEGER(I4B) :: ncol - SELECT CASE (topo) CASE (elem%line) - ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) CASE (elem%triangle) - ans = QuadratureNumber_Triangle(order=order, quadtype=quadratureType) CASE (elem%quadrangle) - ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) CASE (elem%tetrahedron) - ans = QuadratureNumber_Tetrahedron(order=order, quadtype=quadratureType) ! CASE (elem%hexahedron) @@ -134,11 +128,15 @@ ! ! CASE (elem%pyramid) +#ifdef DEBUG_VER CASE DEFAULT CALL Errormsg(msg="No case found for give topo", & - file=__FILE__, routine="obj_QuadratureNumber1()", line=__LINE__, & + file=__FILE__, & + routine="obj_QuadratureNumber1()", & + line=__LINE__, & unitno=stderr) STOP +#endif END SELECT @@ -150,8 +148,12 @@ MODULE PROCEDURE obj_Copy INTEGER(I4B) :: s(2) +LOGICAL(LGT) :: isok + obj%txi = obj2%txi -IF (ALLOCATED(obj2%points)) THEN +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)) @@ -211,9 +213,15 @@ !---------------------------------------------------------------------------- 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) +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 !---------------------------------------------------------------------------- @@ -221,9 +229,15 @@ !---------------------------------------------------------------------------- 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) +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 !---------------------------------------------------------------------------- @@ -231,12 +245,23 @@ !---------------------------------------------------------------------------- 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) +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 !---------------------------------------------------------------------------- @@ -245,10 +270,14 @@ 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) + 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 !---------------------------------------------------------------------------- @@ -257,10 +286,14 @@ 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) + 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 !---------------------------------------------------------------------------- @@ -269,12 +302,14 @@ 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) -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) +IF (isok) THEN nrow = MAX(SIZE(xij, 1), ii) ELSE nrow = ii @@ -287,39 +322,43 @@ 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) + 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) + 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) + 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) @@ -329,7 +368,11 @@ CALL Reallocate(obj%points, nrow, ncol) CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & - refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + refTetrahedron=domainName, & + xij=xij, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) CASE (elem%hexahedron) @@ -346,25 +389,33 @@ 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) + 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) + file=__FILE__, routine="obj_Initiate11()", & + line=__LINE__, unitno=stderr) STOP +#endif END SELECT obj%txi = SIZE(obj%points, 1) - 1 - END PROCEDURE obj_Initiate11 !---------------------------------------------------------------------------- @@ -373,12 +424,14 @@ MODULE PROCEDURE obj_Initiate12 INTEGER(I4B) :: topo, nrow, ncol, ii +LOGICAL(LGT) :: isok topo = ElementTopology(elemType) ii = XiDimension(elemType) -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) +IF (isok) THEN nrow = MAX(SIZE(xij, 1), ii) ELSE nrow = ii @@ -389,74 +442,93 @@ 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) + 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) + 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, & + 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) + 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) + 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__, & + file=__FILE__, & + routine="obj_Initiate12()", & + line=__LINE__, & unitno=stderr) STOP +#endif END SELECT obj%txi = SIZE(obj%points, 1) - 1 - END PROCEDURE obj_Initiate12 !---------------------------------------------------------------------------- diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 index 61cc73fc2..67ae240d0 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 @@ -21,6 +21,14 @@ SUBMODULE(QuadraturePoint_Method) GetMethods 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 @@ -37,9 +45,48 @@ ! getTotalQuadraturepoints !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_GetTotalQuadraturepoints +MODULE PROCEDURE obj_GetTotalQuadraturepoints1 ans = SIZE(obj, 2) -END PROCEDURE obj_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 From ed2b25ca7a07e9e0101c257160c16fb4c1fd038a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Sep 2025 08:10:13 +0900 Subject: [PATCH 053/184] Minor formattin in LineInterpolationUtility --- src/modules/Polynomial/src/LineInterpolationUtility.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90 index f7fec78cd..bccf725cf 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90 @@ -1812,7 +1812,8 @@ END FUNCTION QuadraturePoint_Line3 INTERFACE QuadraturePoint_Line_ MODULE SUBROUTINE QuadraturePoint_Line1_(nips, quadType, layout, xij, & - alpha, beta, lambda, ans, nrow, ncol) + alpha, beta, lambda, ans, nrow, & + ncol) INTEGER(I4B), INTENT(IN) :: nips(1) !! Order of interpolation INTEGER(I4B), INTENT(IN) :: quadType From f992d5e1a3a04f812539d160954e37df58c62343 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Sep 2025 08:10:25 +0900 Subject: [PATCH 054/184] Minor formatting in TriangleInterpolationUtility --- .../src/TriangleInterpolationUtility.F90 | 31 +++++++++++++------ 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index f52b2de36..98f5b6ec8 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -517,7 +517,8 @@ END SUBROUTINE 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 @@ -543,7 +544,8 @@ END FUNCTION InterpolationPoint_Triangle INTERFACE MODULE SUBROUTINE InterpolationPoint_Triangle_(order, ipType, ans, nrow, & - ncol, layout, xij, alpha, beta, lambda) + ncol, layout, xij, & + alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -1099,7 +1101,8 @@ END FUNCTION HeirarchicalBasis_Triangle2 INTERFACE HeirarchicalBasis_Triangle_ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle1_(order, pe1, pe2, pe3, & - xij, refTriangle, ans, nrow, ncol) + 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 @@ -1138,7 +1141,8 @@ END SUBROUTINE HeirarchicalBasis_Triangle1_ INTERFACE HeirarchicalBasis_Triangle_ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle2_(order, xij, & - refTriangle, ans, nrow, ncol) + 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 @@ -1168,7 +1172,11 @@ END SUBROUTINE HeirarchicalBasis_Triangle2_ INTERFACE HeirarchicalBasis_Triangle_ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, & - xij, refTriangle, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, & + xij, refTriangle, & + edgeOrient1, & + edgeOrient2, & + edgeOrient3, & + faceOrient, & ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) @@ -1212,7 +1220,8 @@ END SUBROUTINE HeirarchicalBasis_Triangle3_ INTERFACE LagrangeEvalAll_Triangle MODULE FUNCTION LagrangeEvalAll_Triangle1(order, x, xij, refTriangle, & - coeff, firstCall, basisType) RESULT(ans) + coeff, firstCall, & + basisType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(2) @@ -1244,7 +1253,8 @@ END FUNCTION LagrangeEvalAll_Triangle1 INTERFACE LagrangeEvalAll_Triangle_ MODULE SUBROUTINE LagrangeEvalAll_Triangle1_(order, x, xij, ans, tsize, & - refTriangle, coeff, firstCall, basisType) + refTriangle, coeff, & + firstCall, basisType) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(2) @@ -1284,7 +1294,8 @@ END SUBROUTINE LagrangeEvalAll_Triangle1_ INTERFACE LagrangeEvalAll_Triangle MODULE FUNCTION LagrangeEvalAll_Triangle2(order, x, xij, refTriangle, & - coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans) + coeff, firstCall, basisType, & + alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1319,7 +1330,9 @@ END FUNCTION LagrangeEvalAll_Triangle2 INTERFACE LagrangeEvalAll_Triangle_ MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, & - ncol, refTriangle, coeff, firstCall, basisType, alpha, beta, lambda) + ncol, refTriangle, coeff, & + firstCall, basisType, alpha, & + beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) From 82753c6452e7e39d02f33990b794126c7c949ea1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Sep 2025 10:43:37 +0900 Subject: [PATCH 055/184] Formatting ElemshapeData_H1Methods --- .../ElemshapeData/src/ElemshapeData_H1Methods.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 index 185537cb6..2258d1958 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 @@ -47,7 +47,8 @@ MODULE ElemshapeData_H1Methods INTERFACE Initiate MODULE SUBROUTINE H1_Hierarchy1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -87,7 +88,8 @@ END SUBROUTINE H1_Hierarchy1 INTERFACE Initiate MODULE SUBROUTINE H1_Orthogonal1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -124,7 +126,8 @@ END SUBROUTINE H1_Orthogonal1 INTERFACE Initiate MODULE SUBROUTINE H1_Hermit1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -157,7 +160,8 @@ END SUBROUTINE H1_Hermit1 INTERFACE Initiate MODULE SUBROUTINE H1_Serendipity1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad From 3b91f6ab9b3979ac2afac7be7d5a6eecc4a091a8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Sep 2025 10:49:31 +0900 Subject: [PATCH 056/184] Updating TriangleInterpolation making args of facetConnectivity_Triangle optional --- .../src/TriangleInterpolationUtility.F90 | 11 ++++----- .../TriangleInterpolationUtility@Methods.F90 | 24 ++++++++++++------- 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 index 98f5b6ec8..2c2837bbd 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 @@ -123,7 +123,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" @@ -144,11 +144,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) diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 index 1589a40e1..31df2c156 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 @@ -107,20 +107,26 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FacetConnectivity_Triangle -CHARACTER(3) :: bi +CHARACTER(1) :: bi +LOGICAL(LGT) :: isok -bi = UpperCase(baseInterpol(1:3)) +isok = PRESENT(baseInterpol) +IF (isok) THEN + bi = UpperCase(baseInterpol(1:1)) +ELSE + bi = "L" +END IF SELECT CASE (bi) -CASE ("HIE", "HEI", "ORT") - ans(:, 1) = [1, 2] - ans(:, 2) = [1, 3] - ans(:, 3) = [2, 3] +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) = [1, 2] - ans(:, 2) = [2, 3] - ans(:, 3) = [3, 1] + ans(1:2, 1) = [1, 2] + ans(1:2, 2) = [2, 3] + ans(1:2, 3) = [3, 1] END SELECT END PROCEDURE FacetConnectivity_Triangle From 4d1d43eb350e46343c2d0b7891c7cf4811163e2e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Sep 2025 10:50:04 +0900 Subject: [PATCH 057/184] Updating QuadrangleInterpolationUtility making args of FacetConnectivity_Quadrangle optionals --- src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 index 05a408880..a272e1503 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 @@ -176,8 +176,8 @@ END FUNCTION RefElemDomain_Quadrangle INTERFACE MODULE FUNCTION FacetConnectivity_Quadrangle(baseInterpol, baseContinuity) & RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity + 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) From 45b77b4c112c1772af57450d9610d3e4972b0a2e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 9 Sep 2025 10:50:29 +0900 Subject: [PATCH 058/184] Updating QuadraturePoint_Method adding InitiateFacetQuadrature method --- .../src/QuadraturePoint_Method.F90 | 201 ++++++++++++++++- src/submodules/QuadraturePoint/CMakeLists.txt | 3 +- ...urePoint_Method@FacetQuadratureMethods.F90 | 202 ++++++++++++++++++ 3 files changed, 404 insertions(+), 2 deletions(-) create mode 100644 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 8c3087ca4..04dabf214 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -28,6 +28,7 @@ MODULE QuadraturePoint_Method PRIVATE PUBLIC :: Initiate +PUBLIC :: InitiateFacetQuadrature PUBLIC :: Copy PUBLIC :: ASSIGNMENT(=) PUBLIC :: QuadraturePoint @@ -315,6 +316,7 @@ MODULE SUBROUTINE obj_Initiate6(obj, refElem, nips, quadratureType, & !! Ultraspherical parameter END SUBROUTINE obj_Initiate6 END INTERFACE Initiate + !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -488,7 +490,7 @@ END SUBROUTINE obj_Initiate10 END INTERFACE Initiate !---------------------------------------------------------------------------- -! +! Initiate@ConstructorMethods !---------------------------------------------------------------------------- INTERFACE Initiate @@ -1036,6 +1038,203 @@ END FUNCTION obj_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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt index 9e9866be4..b568d81e9 100644 --- a/src/submodules/QuadraturePoint/CMakeLists.txt +++ b/src/submodules/QuadraturePoint/CMakeLists.txt @@ -20,4 +20,5 @@ 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@ConstructorMethods.F90 + ${src_path}/QuadraturePoint_Method@FacetQuadratureMethods.F90) 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..4910b80b2 --- /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), nipsy(1), nipsz(1), tsize, 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 From 690993c194de357b8a944fa1928479252c1e932b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Sep 2025 12:16:24 +0900 Subject: [PATCH 059/184] Updating ElemshapeData_Hierarchical adding HierarchicalFacetElemShapeData --- .../src/ElemshapeData_Hierarchical.F90 | 62 ++++++++++++++-- .../ElemshapeData_Hierarchical@Methods.F90 | 74 ++++++++++++++++--- 2 files changed, 118 insertions(+), 18 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 index 15c3184f6..9c83a8d71 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 @@ -28,6 +28,7 @@ MODULE ElemshapeData_Hierarchical PRIVATE PUBLIC :: HierarchicalElemShapeData +PUBLIC :: HierarchicalFacetElemShapeData PUBLIC :: Initiate !---------------------------------------------------------------------------- @@ -39,9 +40,9 @@ MODULE ElemshapeData_Hierarchical ! 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) + 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 @@ -80,8 +81,9 @@ END SUBROUTINE HierarchicalElemShapeData1 ! summary: This routine initiate the shape data INTERFACE HierarchicalElemShapeData - MODULE SUBROUTINE HierarchicalElemShapeData2(obj, quad, refelem, cellOrder, & - faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + 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 @@ -105,9 +107,9 @@ END SUBROUTINE HierarchicalElemShapeData2 !---------------------------------------------------------------------------- INTERFACE HierarchicalElemShapeData - MODULE SUBROUTINE HierarchicalElemShapeData3(obj, quad, refelem, & - baseContinuity, baseInterpolation, cellOrder, & - faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + 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 @@ -135,4 +137,48 @@ END SUBROUTINE HierarchicalElemShapeData3 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/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 index 6c7862129..44fb5a0a0 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 @@ -16,9 +16,14 @@ ! SUBMODULE(ElemShapeData_Hierarchical) Methods +USE ErrorHandling, ONLY: Errormsg +USE GlobalData, ONLY: stderr + USE InputUtility, ONLY: Input -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate, & + Refelem_GetFaceElemType => GetFaceElemType, & + Refelem_RefCoord_ => RefCoord_ USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE @@ -48,7 +53,7 @@ MODULE PROCEDURE HierarchicalElemShapeData1 REAL(DFP), ALLOCATABLE :: temp(:, :, :) -INTEGER(I4B) :: ipType0, basisType0, nips, nns, ii, jj, kk +INTEGER(I4B) :: nips, nns, ii, jj, kk ! CALL DEALLOCATE (obj) @@ -101,11 +106,13 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HierarchicalElemShapeData2 -CALL HierarchicalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & - xidim=refelem%xidimension, elemType=refelem%name, & - refelemCoord=refelem%xij, domainName=refelem%domainName, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +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 !---------------------------------------------------------------------------- @@ -113,9 +120,56 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HierarchicalElemShapeData3 -CALL HierarchicalElemShapeData2(obj=obj, quad=quad, refelem=refelem, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +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, & + "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 From 3969af8b57e7b9c5c7e44f24cb65edaecb0a4feb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Sep 2025 12:25:07 +0900 Subject: [PATCH 060/184] Updating ElemshapeData_Lagrange adding LagrangeFacetElemShapeData --- .../src/ElemshapeData_Lagrange.F90 | 65 +++++++++++++++++-- .../src/ElemshapeData_Lagrange@Methods.F90 | 55 +++++++++++++--- 2 files changed, 108 insertions(+), 12 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 index 9e35d13e3..97d3e5b90 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 @@ -28,6 +28,7 @@ MODULE ElemshapeData_Lagrange PRIVATE PUBLIC :: LagrangeElemShapeData +PUBLIC :: LagrangeFacetElemShapeData PUBLIC :: Initiate !---------------------------------------------------------------------------- @@ -40,8 +41,10 @@ MODULE ElemshapeData_Lagrange INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, & - elemType, refelemCoord, domainName, order, ipType, basisType, & - coeff, firstCall, alpha, beta, lambda) + elemType, refelemCoord, & + domainName, order, ipType, & + basisType, coeff, firstCall, & + alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! element shape data TYPE(QuadraturePoint_), INTENT(IN) :: quad @@ -85,7 +88,8 @@ END SUBROUTINE LagrangeElemShapeData1 INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData2(obj, quad, refelem, order, & - ipType, basisType, coeff, firstCall, alpha, beta, lambda) + ipType, basisType, coeff, & + firstCall, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj TYPE(QuadraturePoint_), INTENT(IN) :: quad CLASS(ReferenceElement_), INTENT(IN) :: refelem @@ -113,7 +117,8 @@ END SUBROUTINE LagrangeElemShapeData2 INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData3(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, coeff, firstCall, & + baseInterpolation, order, ipType, & + basisType, coeff, firstCall, & alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj TYPE(QuadraturePoint_), INTENT(IN) :: quad @@ -141,4 +146,56 @@ END SUBROUTINE LagrangeElemShapeData3 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/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 index 711b620f6..f2da9c9b5 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 @@ -18,7 +18,9 @@ SUBMODULE(ElemShapeData_Lagrange) Methods USE InputUtility, ONLY: Input -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate, & + Refelem_GetFaceElemType => GetFaceElemType, & + Refelem_RefCoord_ => RefCoord_ USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE @@ -150,11 +152,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeElemShapeData2 -CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & +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) + 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 !---------------------------------------------------------------------------- @@ -162,9 +167,43 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeElemShapeData3 -CALL LagrangeElemShapeData2(obj=obj, quad=quad, refelem=refelem, & - order=order, ipType=ipType, basisType=basisType, coeff=coeff, & - firstCall=firstCall, alpha=alpha, beta=beta, lambda=lambda) +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 From 2f86834cc3f549dd69ea81666860f2c577e4a9e2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Sep 2025 12:25:34 +0900 Subject: [PATCH 061/184] Updating Geometry modules Adding GetFaceElemType2 method --- .../Geometry/src/ReferenceElement_Method.F90 | 28 +++++++++- .../src/ReferenceHexahedron_Method.F90 | 42 +++++++++++--- .../Geometry/src/ReferenceLine_Method.F90 | 36 ++++++++++-- .../Geometry/src/ReferencePrism_Method.F90 | 42 +++++++++++--- .../Geometry/src/ReferencePyramid_Method.F90 | 40 ++++++++++--- .../src/ReferenceQuadrangle_Method.F90 | 36 ++++++++++-- .../src/ReferenceTetrahedron_Method.F90 | 42 +++++++++++--- .../Geometry/src/ReferenceTriangle_Method.F90 | 36 ++++++++++-- ...eferenceElement_Method@GeometryMethods.F90 | 56 ++++++++++++++++--- .../ReferenceHexahedron_Method@Methods.F90 | 28 +++++++++- .../src/ReferenceLine_Method@Methods.F90 | 13 ++++- .../src/ReferencePrism_Method@Methods.F90 | 20 ++++++- .../src/ReferencePyramid_Method@Methods.F90 | 21 ++++++- .../ReferenceQuadrangle_Method@Methods.F90 | 15 ++++- .../ReferenceTetrahedron_Method@Methods.F90 | 33 ++++++++++- .../src/ReferenceTriangle_Method@Methods.F90 | 40 ++++++++++++- src/submodules/include/errors.F90 | 17 ++++++ 17 files changed, 475 insertions(+), 70 deletions(-) create mode 100644 src/submodules/include/errors.F90 diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index f33c6cf3c..5e9e1d02c 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -162,7 +162,7 @@ END FUNCTION RefCoord END INTERFACE !---------------------------------------------------------------------------- -! +! RefCoord_@GeometryMethods !---------------------------------------------------------------------------- INTERFACE @@ -332,6 +332,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 !---------------------------------------------------------------------------- diff --git a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 b/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 index af249edaa..47774757c 100644 --- a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 +++ b/src/modules/Geometry/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/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90 index a609e48b0..8c39b8877 100644 --- a/src/modules/Geometry/src/ReferenceLine_Method.F90 +++ b/src/modules/Geometry/src/ReferenceLine_Method.F90 @@ -500,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(:) @@ -513,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/Geometry/src/ReferencePrism_Method.F90 b/src/modules/Geometry/src/ReferencePrism_Method.F90 index 486e6237e..9a9eda535 100644 --- a/src/modules/Geometry/src/ReferencePrism_Method.F90 +++ b/src/modules/Geometry/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/Geometry/src/ReferencePyramid_Method.F90 b/src/modules/Geometry/src/ReferencePyramid_Method.F90 index 64e15d10c..f468e75cb 100644 --- a/src/modules/Geometry/src/ReferencePyramid_Method.F90 +++ b/src/modules/Geometry/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/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 index 4756e86b4..741d12967 100644 --- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 +++ b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 @@ -469,9 +469,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(:) @@ -482,7 +482,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, & !! 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/Geometry/src/ReferenceTetrahedron_Method.F90 b/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 index 6dd64c981..dfc18fc24 100644 --- a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 +++ b/src/modules/Geometry/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/Geometry/src/ReferenceTriangle_Method.F90 b/src/modules/Geometry/src/ReferenceTriangle_Method.F90 index 2e71a0e39..83e9ddf94 100644 --- a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 +++ b/src/modules/Geometry/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/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 index cfd0697ba..6bed1f443 100644 --- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 +++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 @@ -479,43 +479,85 @@ SELECT CASE (topo) CASE (Line) - CALL GetFaceElemType_Line(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Triangle) - CALL GetFaceElemType_Triangle(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Quadrangle) - CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Tetrahedron) - CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Hexahedron) - CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Prism) - CALL GetFaceElemType_Prism(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Pyramid) - 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/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 index fadad220e..e3a0cb997 100644 --- a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 @@ -598,7 +598,7 @@ ! GetFaceElemType_Hexahedron !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Hexahedron +MODULE PROCEDURE GetFaceElemType_Hexahedron1 INTEGER(I4B) :: elemType0 elemType0 = Input(default=Hexahedron8, option=elemType) @@ -621,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/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 index b6805ae2e..cb10e1d96 100644 --- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 @@ -372,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/Geometry/src/ReferencePrism_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 index 281bc250e..7f325ee24 100644 --- a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 +++ b/src/submodules/Geometry/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/Geometry/src/ReferencePyramid_Method@Methods.F90 b/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 index d2638525f..14302d8de 100644 --- a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 +++ b/src/submodules/Geometry/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/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 index b7f438a7f..b4391170b 100644 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 @@ -663,11 +663,22 @@ END SUBROUTINE PARALLELOGRAMAREA2D ! GetFaceElemType_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Quadrangle +MODULE PROCEDURE GetFaceElemType_Quadrangle1 INTEGER(I4B) :: order order = ElementOrder_Quadrangle(Input(default=Quadrangle, option=elemType)) 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/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 index 9073009d2..b2c9a0b47 100644 --- a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 @@ -570,7 +570,7 @@ ! GetFaceElemType !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Tetrahedron +MODULE PROCEDURE GetFaceElemType_Tetrahedron1 INTEGER(I4B) :: elemType0 elemType0 = Input(default=Tetrahedron4, option=elemType) @@ -606,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/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 index 11712ee97..49d90b68f 100644 --- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 +++ b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 @@ -808,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) @@ -842,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/include/errors.F90 b/src/submodules/include/errors.F90 new file mode 100644 index 000000000..2a20f1a35 --- /dev/null +++ b/src/submodules/include/errors.F90 @@ -0,0 +1,17 @@ +!---------------------------------------------------------------------------- +! AssertError1 +!---------------------------------------------------------------------------- + +SUBROUTINE AssertError1(a, myName, msg) + LOGICAL, INTENT(IN) :: a + CHARACTER(*), INTENT(IN) :: myName + CHARACTER(*), INTENT(IN) :: msg + + IF (.NOT. a) THEN + CALL Errormsg(msg=msg, file=__FILE__, routine=myName, & + line=__LINE__, unitno=stderr) + RETURN + END IF + +END SUBROUTINE AssertError1 + From ddcf4a494692ad55ed6572e79ba1fb26d7398c48 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Sep 2025 21:43:06 +0900 Subject: [PATCH 062/184] updating Elemshapedata updating ElemshapeData Set2 and Set3 methods --- .../src/ElemshapeData_SetMethods.F90 | 37 +++++++-------- .../src/ElemshapeData_SetMethods@Methods.F90 | 45 +++++++------------ 2 files changed, 30 insertions(+), 52 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 index fb8531e84..40d6a8b0c 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 @@ -388,12 +388,17 @@ END SUBROUTINE elemsd_Set1 !@endnote INTERFACE Set - MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & - celldNdXi, facetN, facetdNdXi, facetNptrs) + 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(:, :) @@ -401,7 +406,6 @@ MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & REAL(DFP), INTENT(IN) :: celldNdXi(:, :, :) REAL(DFP), INTENT(IN) :: facetdNdXi(:, :, :) !! Local derivative of shape functions for geometry - INTEGER(I4B), INTENT(IN) :: facetNptrs(:) END SUBROUTINE elemsd_Set2 END INTERFACE Set @@ -419,22 +423,10 @@ END SUBROUTINE elemsd_Set2 INTERFACE Set MODULE PURE SUBROUTINE elemsd_Set3( & - & masterFacetobj, & - & masterCellobj, & - & masterCellval, & - & masterCellN, & - & masterCelldNdXi, & - & masterFacetN, & - & masterFacetdNdXi, & - & masterFacetNptrs, & - & slaveFacetobj, & - & slaveCellobj, & - & slaveCellval, & - & slaveCellN, & - & slaveCelldNdXi, & - & slaveFacetN, & - & slaveFacetdNdXi, & - & slaveFacetNptrs) + 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(:, :) @@ -448,8 +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 - INTEGER(I4B), INTENT(IN) :: masterFacetNptrs(:) - !! + 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 @@ -466,7 +458,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( & REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :) !! Local derivative of shape function for geometry of facet element !! of slave - INTEGER(I4B), INTENT(IN) :: slaveFacetNptrs(:) + REAL(DFP), INTENT(IN) :: slaveFacetVal(:, :) + !! slave facet xij END SUBROUTINE elemsd_Set3 END INTERFACE Set diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 index a8ad98d19..bd49a5476 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -132,7 +132,6 @@ MATMUL(obj%dNdXi(1:obj%nns, 1:obj%nsd, ips), & invJacobian(1:obj%nsd, 1:obj%nsd)) END DO - END PROCEDURE elemsd_SetdNdXt !---------------------------------------------------------------------------- @@ -249,28 +248,24 @@ CALL SetJs(obj=cellobj) CALL SetdNdXt(obj=cellobj) CALL SetBarycentricCoord(obj=cellobj, val=cellval, N=cellN) - -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 - +cellobj%Js(1:cellobj%nips) = facetobj%Js(1:facetobj%nips) +cellobj%Ws(1:cellobj%nips) = facetobj%Ws(1:facetobj%nips) END PROCEDURE elemsd_Set2 !---------------------------------------------------------------------------- @@ -278,25 +273,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Set3 -! CALL Set( & - & facetobj=masterFacetObj, & - & cellobj=masterCellObj, & - & cellVal=masterCellVal, & - & cellN=masterCellN, & - & celldNdXi=masterCelldNdXi, & - & facetN=masterFacetN, & - & facetdNdXi=masterFacetdNdXi, facetNptrs=masterFacetNptrs) -! + 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, facetNptrs=slaveFacetNptrs) -! + facetobj=slaveFacetObj, cellobj=slaveCellObj, cellVal=slaveCellVal, & + cellN=slaveCellN, celldNdXi=slaveCelldNdXi, facetN=slaveFacetN, & + facetdNdXi=slaveFacetdNdXi, facetVal=slaveFacetVal) END PROCEDURE elemsd_Set3 !---------------------------------------------------------------------------- From 3e01724decdbd22b94605720af09760440bbf483 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Sep 2025 09:16:16 +0900 Subject: [PATCH 063/184] Formatting QuadrangleInterpolationUtility@Methods --- .../Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 32243f79b..3c6064a74 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -278,8 +278,8 @@ ! !---------------------------------------------------------------------------- -PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, & - startNode) +PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, & + pointsOrder, startNode) INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) INTEGER(I4B), INTENT(IN) :: startNode From 76a78e829368d51763eeaf67f3e1c3313d865120 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Sep 2025 16:26:26 +0900 Subject: [PATCH 064/184] Updating FEVariable_SetMethods --- src/modules/FEVariable/src/FEVariable_SetMethod.F90 | 3 +++ .../FEVariable/src/FEVariable_IOMethod@Methods.F90 | 10 ++++++---- .../src/FEVariable_SetMethod@ScalarMethods.F90 | 7 +++++++ 3 files changed, 16 insertions(+), 4 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 index d72332631..d66a9974e 100644 --- a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 @@ -30,8 +30,11 @@ MODULE FEVariable_SetMethod USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE + PRIVATE +PUBLIC :: Set + !---------------------------------------------------------------------------- ! Set !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 index 0d33196bc..76fb2be99 100644 --- a/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 @@ -54,8 +54,9 @@ SELECT CASE (obj%varType) CASE (Constant) CALL Util_Display("VarType: Constant", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & - 'VALUE: ', unitno=unitno) + CALL Util_Display( & + GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) CASE (Space) CALL Util_Display("VarType: Space", unitno=unitno) @@ -67,8 +68,9 @@ 'VALUE: ', unitno=unitno) CASE (SpaceTime) CALL Util_Display("VarType: Space & Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & - 'VALUE: ', unitno=unitno) + CALL Util_Display( & + GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) CASE DEFAULT CALL Util_Display("VarType: UNKNOWN", unitno=unitno) diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 index 39afff6d7..64fd82189 100644 --- a/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 @@ -25,6 +25,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Set1 +obj%len = 1 +obj%s(1) = obj%len IF (addContribution) THEN obj%val(1) = obj%val(1) + scale * val ELSE @@ -37,6 +39,8 @@ !---------------------------------------------------------------------------- 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 @@ -51,6 +55,9 @@ 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 From 6292ee3a4311b4236ac5ef3b78904734d25d7d44 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 11 Sep 2025 16:26:40 +0900 Subject: [PATCH 065/184] Updating ElemshapeData_SetMethods --- .../ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 index bd49a5476..d30bc6858 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -256,8 +256,8 @@ ! 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(1:facetobj%nns, 1:facetobj%nsd, 1:facetobj%nips) = & - cellobj%dNdXt(1:cellobj%nns, 1:cellobj%nsd, 1:cellobj%nips) +! 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 From 6702f60f3ed921dea4a8665a28536bc408b006eb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 12 Sep 2025 09:04:44 +0900 Subject: [PATCH 066/184] Updating FEVariable Removing bug from FEVariable_ScalarInterpolationMethod FEVariable_VectorInterpolationMethod FEVariable_MatrixInterpolationMethod --- .../ForceVector/src/ForceVector_Method.F90 | 42 +++++++++---------- ...able_MatrixInterpolationMethod@Methods.F90 | 16 +++---- ...able_ScalarInterpolationMethod@Methods.F90 | 20 ++++----- ...able_VectorInterpolationMethod@Methods.F90 | 20 ++++----- 4 files changed, 49 insertions(+), 49 deletions(-) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index cdd696190..929872ce5 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -23,7 +23,7 @@ MODULE ForceVector_Method PRIVATE PUBLIC :: ForceVector -public :: ForceVector_ +PUBLIC :: ForceVector_ !---------------------------------------------------------------------------- ! ForceVector @@ -42,7 +42,7 @@ MODULE ForceVector_Method ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector1(test) RESULT(ans) + MODULE FUNCTION ForceVector1(test) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), ALLOCATABLE :: ans(:) END FUNCTION ForceVector1 @@ -65,7 +65,7 @@ END FUNCTION ForceVector1 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_1(test, ans, tsize) + MODULE SUBROUTINE ForceVector_1(test, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), INTENT(INOUT) :: ans(:) INTEGER(I4B), INTENT(OUT) :: tsize @@ -87,7 +87,7 @@ END SUBROUTINE ForceVector_1 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector2(test, c, crank) RESULT(ans) + MODULE FUNCTION ForceVector2(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableScalar_), INTENT(IN) :: crank @@ -110,7 +110,7 @@ END FUNCTION ForceVector2 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_2(test, c, crank, ans, tsize) + MODULE SUBROUTINE ForceVector_2(test, c, crank, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c !! Scalar variables @@ -137,7 +137,7 @@ END SUBROUTINE ForceVector_2 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector3(test, c, crank) RESULT(ans) + MODULE FUNCTION ForceVector3(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableVector_), INTENT(IN) :: crank @@ -162,7 +162,7 @@ END FUNCTION ForceVector3 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_3(test, c, crank, ans, nrow, ncol) + 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 @@ -188,7 +188,7 @@ END SUBROUTINE ForceVector_3 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector4(test, c, crank) RESULT(ans) + MODULE FUNCTION ForceVector4(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableMatrix_), INTENT(IN) :: crank @@ -213,8 +213,8 @@ END FUNCTION ForceVector4 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_4(test, c, crank, ans, dim1, dim2, & - dim3) + 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 @@ -240,7 +240,7 @@ END SUBROUTINE ForceVector_4 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector5(test, c1, c1rank, c2, c2rank) & + MODULE FUNCTION ForceVector5(test, c1, c1rank, c2, c2rank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c1 @@ -268,8 +268,8 @@ END FUNCTION ForceVector5 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_5(test, c1, c1rank, c2, c2rank, ans, & - tsize) + 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 @@ -289,7 +289,7 @@ END SUBROUTINE ForceVector_5 ! summary: Force vector INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) & + MODULE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c1 @@ -309,8 +309,8 @@ END FUNCTION ForceVector6 ! summary: Force vector INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_6(test, c1, c1rank, c2, c2rank, ans, & - nrow, ncol) + 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 @@ -338,7 +338,7 @@ END SUBROUTINE ForceVector_6 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector7(test, c1, c1rank, c2, c2rank) & + MODULE FUNCTION ForceVector7(test, c1, c1rank, c2, c2rank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c1 @@ -366,8 +366,8 @@ END FUNCTION ForceVector7 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_7(test, c1, c1rank, c2, c2rank, ans, & - dim1, dim2, dim3) + 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 @@ -393,7 +393,7 @@ END SUBROUTINE ForceVector_7 ! $$ INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector8(test, c) RESULT(ans) + MODULE FUNCTION ForceVector8(test, c) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), INTENT(IN) :: c(:) !! defined on quadrature point @@ -416,7 +416,7 @@ END FUNCTION ForceVector8 ! $$ INTERFACE ForceVector_ - MODULE PURE SUBROUTINE ForceVector_8(test, c, ans, tsize) + MODULE SUBROUTINE ForceVector_8(test, c, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), INTENT(IN) :: c(:) !! defined on quadrature point diff --git a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 index 111b39b9d..adebfe74c 100644 --- a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 @@ -292,12 +292,12 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ! GetInterpolation_ !---------------------------------------------------------------------------- -! obj%vartype is nodal +! obj%defineon is nodal ! Nodal Matrix Space ! Convert nodal values to quadrature values by using N(:,:) ! make sure nns .LE. obj%len ! -! obj%vartype is quadrature +! obj%defineon is quadrature ! No need for interpolation, just returnt the quadrature values ! make sure nips .LE. obj%len MODULE PROCEDURE MatrixSpaceGetInterpolation_1 @@ -309,7 +309,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon ) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=scale, N=N, & @@ -345,7 +345,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans%val(ansStart + 1:ansEnd) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=scale, N=N, & @@ -378,7 +378,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ncol = obj%s(2) IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=scale, N=N, & @@ -420,7 +420,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) valEnd = 0 @@ -465,7 +465,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans%val(ansStart + 1:ansEnd) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) valEnd = 0 @@ -506,7 +506,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) valEnd = 0 diff --git a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 index 02f0f0b65..e406d93b9 100644 --- a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 @@ -113,7 +113,7 @@ END SUBROUTINE MasterGetInterpolation3_ tsize = nips IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) !! convert nodal values to quadrature values by using N !! make sure nns .LE. obj%len @@ -146,7 +146,7 @@ END SUBROUTINE MasterGetInterpolation3_ IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolation1_(ans=ans%val, scale=scale, N=N, & nns=nns, nips=nips, val=obj%val, & @@ -165,17 +165,17 @@ END SUBROUTINE MasterGetInterpolation3_ ! GetInterpolation_ !---------------------------------------------------------------------------- -! obj%vartype is nodal +! obj%defineon is nodal ! convert nodal values to quadrature values by using N ! make sure nns .LE. obj%len ! -! obj%vartype is quadrature +! 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%vartype) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolation3_(ans=ans, scale=scale, N=N, nns=nns, & spaceIndx=spaceIndx, val=obj%val, valStart=0) @@ -200,7 +200,7 @@ END SUBROUTINE MasterGetInterpolation3_ ansStart = 0 -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) !! convert nodal values to quadrature values by using N !! make sure nns .LE. obj%len @@ -240,7 +240,7 @@ END SUBROUTINE MasterGetInterpolation3_ ansStart = (timeIndx - 1) * ans%s(1) IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) DO aa = 1, nnt @@ -266,13 +266,13 @@ END SUBROUTINE MasterGetInterpolation3_ ! GetInterpolation_ !---------------------------------------------------------------------------- -! obj%vartype is nodal +! 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%vartype is quadrature +! obj%defineon is quadrature ! No need for interpolation, just returnt the quadrature values ! make sure nips .LE. obj%len @@ -283,7 +283,7 @@ END SUBROUTINE MasterGetInterpolation3_ IF (.NOT. addContribution) ans = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) DO aa = 1, nnt diff --git a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 index 4ad22fc2f..7ff0c1ff5 100644 --- a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 @@ -246,7 +246,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ncol = nips IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) !! Nodal Vector Space !! Convert nodal values to quadrature values by using N(:,:) @@ -287,7 +287,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans%val(1 + ansStart:ansEnd) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=scale, N=N, & nns=nns, nsd=nsd, nips=nips, & @@ -311,13 +311,13 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ! GetInterpolation_ !---------------------------------------------------------------------------- -! obj%vartype is nodal +! obj%defineon is nodal ! ! Nodal Vector Space ! Convert nodal values to quadrature values by using N(:,:) ! make sure nns .LE. obj%len ! -! obj%vartype is quadrature +! obj%defineon is quadrature ! No need for interpolation, just returnt the quadrature values ! make sure nips .LE. obj%len MODULE PROCEDURE VectorSpaceGetInterpolation_3 @@ -326,7 +326,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ tsize = obj%s(1) IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=scale, N=N, nns=nns, & @@ -358,7 +358,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ncol = nips IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) !! Convert nodal values to quadrature values by using N !! make sure nns .LE. obj%len @@ -413,7 +413,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ansEnd = ansStart + ans%s(1) * ans%s(2) valStart = 0 -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) valEnd = 0 @@ -446,7 +446,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ! GetInterpolation_ !---------------------------------------------------------------------------- -! obj%vartype is nodal +! obj%defineon is nodal ! ! Convert nodal values to quadrature values by using N ! @@ -455,7 +455,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ ! obj%s(2) should be atleast nns ! obj%s(3) should be atleast nnt ! -! obj%vartype is quadrature +! obj%defineon is quadrature ! ! No need for interpolation, just return the quadrature values ! make sure nips .LE. obj%len @@ -467,7 +467,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ tsize = obj%s(1) IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP -SELECT CASE (obj%varType) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) valEnd = 0 From e923515ec4c4a0ed0dc15809399cc51d66b22f52 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 12 Sep 2025 09:05:04 +0900 Subject: [PATCH 067/184] Updating ForceVector removing a bug in ForceVector --- .../ForceVector/src/ForceVector_Method@Methods.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index 0fc559225..d05c185c1 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -21,6 +21,10 @@ USE ProductUtility, ONLY: OuterProd, OuterProd_ USE FEVariable_Method, ONLY: FEVariableSize => Size +#ifdef DEBUG_VER +USE Display_Method, ONLY: Display +#endif + IMPLICIT NONE CONTAINS @@ -45,6 +49,7 @@ ! main tsize = test%nns +ans(1:tsize) = 0.0_DFP DO ips = 1, test%nips realval = test%js(ips) * test%ws(ips) * test%thickness(ips) @@ -76,11 +81,14 @@ INTEGER(I4B) :: ips tsize = test%nns +ans(1:tsize) = 0.0_DFP DO ips = 1, test%nips CALL GetInterpolation_(obj=test, ans=realval, val=c, scale=one, & addContribution=no, timeIndx=1, spaceIndx=ips) + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * realval + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO @@ -219,6 +227,7 @@ ! main tsize = test%nns +ans(1:tsize) = 0.0_DFP DO ips = 1, test%nips CALL GetInterpolation_(obj=test, ans=c1bar, val=c1, & @@ -398,6 +407,7 @@ REAL(DFP) :: realval tsize = test%nns +ans(1:tsize) = 0.0_DFP DO ips = 1, test%nips realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c(ips) From 212214ea6d8a072272d1c30812d445226a659150 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 3 Oct 2025 14:36:50 +0900 Subject: [PATCH 068/184] Minor updates in Lapack_Method --- src/modules/Lapack/src/Lapack_Method.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From b9887869fa5735bf33289de97be5f9ad9aedcad9 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 3 Oct 2025 14:37:04 +0900 Subject: [PATCH 069/184] Updates in QuadrangleInterpolationUtility --- ...QuadrangleInterpolationUtility@Methods.F90 | 94 +++++++++++-------- 1 file changed, 56 insertions(+), 38 deletions(-) diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 index 3c6064a74..e837b8026 100644 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 @@ -15,7 +15,29 @@ ! along with this program. If not, see SUBMODULE(QuadrangleInterpolationUtility) Methods -USE BaseMethod +USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, & + InterpolationPoint_Line_, & + BasisEvalAll_Line_, & + BasisGradientEvalAll_Line_, & + QuadraturePoint_Line_ +USE ReallocateUtility, ONLY: Reallocate +USE MappingUtility, ONLY: FromBiUnitQuadrangle2Quadrangle_, & + FromBiUnitQuadrangle2UnitQuadrangle_, & + JacobianQuadrangle +USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ +USE GE_LUMethods, ONLY: GetLU, LUSolve +USE InputUtility, ONLY: Input +USE LegendrePolynomialUtility, ONLY: LegendreEvalAll_, & + LegendreGradientEvalAll_ +USE JacobiPolynomialUtility, ONLY: JacobiEvalAll_, & + JacobiGradientEvalAll_ +USE LobattoPolynomialUtility, ONLY: LobattoEvalAll_, & + LobattoGradientEvalAll_ +USE ErrorHandling, ONLY: Errormsg +USE F95_BLAS, ONLY: GEMM +USE StringUtility, ONLY: UpperCase +USE GE_CompRoutineMethods, ONLY: GetInvMat + IMPLICIT NONE CONTAINS @@ -203,8 +225,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EquidistancePoint_Quadrangle2_ -CALL InterpolationPoint_Quadrangle2_(p=p, q=q, ipType1=Equidistance, & - ipType2=Equidistance, ans=ans, nrow=nrow, ncol=ncol, layout="VEFC", xij=xij) +CALL InterpolationPoint_Quadrangle2_( & + p=p, q=q, ipType1=Equidistance, ipType2=Equidistance, ans=ans, & + nrow=nrow, ncol=ncol, layout="VEFC", xij=xij) END PROCEDURE EquidistancePoint_Quadrangle2_ !---------------------------------------------------------------------------- @@ -358,7 +381,7 @@ END SUBROUTINE GetEdgeConnectivityHelpClock MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise ! internal variables -INTEGER(I4B) :: cnt, m, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B) :: cnt, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 INTEGER(I4B), PARAMETER :: tEdges = 4 INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & pointsOrder(4) @@ -648,12 +671,8 @@ END SUBROUTINE GetEdgeConnectivityHelpClock 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) + 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 @@ -673,9 +692,10 @@ END SUBROUTINE GetEdgeConnectivityHelpClock !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Quadrangle1 -ans = InterpolationPoint_Quadrangle2(p=order, q=order, ipType1=ipType, & - ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda) +ans = InterpolationPoint_Quadrangle2( & + p=order, q=order, ipType1=ipType, ipType2=ipType, xij=xij, & + layout=layout, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda) END PROCEDURE InterpolationPoint_Quadrangle1 !---------------------------------------------------------------------------- @@ -683,10 +703,10 @@ END SUBROUTINE GetEdgeConnectivityHelpClock !---------------------------------------------------------------------------- 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) +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_ !---------------------------------------------------------------------------- @@ -700,10 +720,10 @@ END SUBROUTINE GetEdgeConnectivityHelpClock 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) +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 @@ -725,13 +745,13 @@ END SUBROUTINE GetEdgeConnectivityHelpClock 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=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) +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 @@ -750,10 +770,9 @@ END SUBROUTINE GetEdgeConnectivityHelpClock 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) + 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_ @@ -781,8 +800,8 @@ END SUBROUTINE GetEdgeConnectivityHelpClock ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP ! V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Quadrangle, & - ans=V, nrow=nrow, ncol=ncol) +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Quadrangle, ans=V, & + nrow=nrow, ncol=ncol) CALL GetLU(A=V, IPIV=ipiv, info=info) CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) END PROCEDURE LagrangeCoeff_Quadrangle1_ @@ -887,7 +906,7 @@ END SUBROUTINE GetEdgeConnectivityHelpClock !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Quadrangle5_ -INTEGER(I4B) :: jj, kk, basisType(2) +INTEGER(I4B) :: basisType(2) basisType(1) = Input(default=Monomial, option=basisType1) basisType(2) = Input(default=Monomial, option=basisType2) @@ -1202,7 +1221,6 @@ PURE SUBROUTINE VertexBasis_Quadrangle3_(L1, L2, ans, nrow, ncol) ans(ii, 3) = L1(ii, 1) * L2(ii, 1) ans(ii, 4) = L1(ii, 0) * L2(ii, 1) END DO - END SUBROUTINE VertexBasis_Quadrangle3_ !---------------------------------------------------------------------------- @@ -1708,9 +1726,9 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_ -INTEGER(I4B) :: a, b, indx(4), maxP, maxQ +INTEGER(I4B) :: indx(4), maxP, maxQ REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) -LOGICAL(LGT) :: isok, abool +LOGICAL(LGT) :: isok nrow = SIZE(xij, 2) ! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 @@ -2059,7 +2077,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ MODULE PROCEDURE QuadraturePoint_Quadrangle1_ ! internal variables REAL(DFP) :: x(4, nipsx(1)), y(2, nipsy(1)), areal -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq +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]) From edc48cc228fed65320c5eb08f5c7d652e4ba098c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 3 Oct 2025 14:37:11 +0900 Subject: [PATCH 070/184] Update in FEVariable --- .../FEVariable/src/FEVariable_SetMethod.F90 | 48 +++++++++++++++++++ .../FEVariable_SetMethod@MatrixMethods.F90 | 29 +++++++++++ .../FEVariable_SetMethod@ScalarMethods.F90 | 14 ++++++ .../FEVariable_SetMethod@VectorMethods.F90 | 26 ++++++++++ 4 files changed, 117 insertions(+) diff --git a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 index d66a9974e..099efef6f 100644 --- a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 @@ -179,4 +179,52 @@ MODULE PURE SUBROUTINE obj_Set9(obj, val, rank, vartype, scale, & 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/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 index f3541402e..1af1ddc5c 100644 --- a/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 @@ -107,6 +107,35 @@ END IF END PROCEDURE obj_Set9 +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set12 +INTEGER(I4B) :: ii, jj, kk, cnt + +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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 index 64fd82189..54ca3060d 100644 --- a/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 @@ -77,6 +77,20 @@ 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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 index 5a03ceac9..1ed9a6fef 100644 --- a/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 @@ -87,6 +87,32 @@ END IF END PROCEDURE obj_Set6 +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set11 +INTEGER(I4B) :: ii, jj, cnt + +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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From a8fe5917fa57f2b3876504f8edc019b5c59dfe5f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 9 Oct 2025 10:49:04 +0900 Subject: [PATCH 071/184] Formatting in BaseType --- src/modules/BaseType/src/BaseType.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 9e4be8825..74b931410 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -76,8 +76,10 @@ MODULE BaseType Constant, Space, Time, Spacetime, & SolutionDependent, RandomSpace -USE GlobalData, ONLY: Point, Line, Triangle, Quadrangle, Tetrahedron, & - Hexahedron, Prism, Pyramid +USE GlobalData, ONLY: Point, Line, Triangle, & + Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, & + Quadrangle16, & + Tetrahedron, Hexahedron, Prism, Pyramid USE String_Class, ONLY: String @@ -1098,7 +1100,7 @@ END SUBROUTINE highorder_refelem ! {!pages/FEVariable_.md!} TYPE :: FEVariable_ - LOGICAL( LGT ) :: isInit = .false. + LOGICAL(LGT) :: isInit = .FALSE. !! True if it is initiated INTEGER(I4B) :: s(MAX_RANK_FEVARIABLE) = 0 !! shape of the data @@ -1914,6 +1916,9 @@ END FUNCTION iface_MatrixFunction 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 From 914a4d2dd3877e67c18c2cf046cbd2a24096ad01 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 9 Oct 2025 10:50:31 +0900 Subject: [PATCH 072/184] Updating LineInterpolationUtility Updating GetTotalInDOF_Line --- .../Polynomial/src/LineInterpolationUtility@Methods.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 index 4c309f30c..b831c0f1b 100644 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 @@ -158,6 +158,7 @@ MODULE PROCEDURE GetTotalInDOF_Line ans = order - 1_I4B +IF (ans .LT. 0_I4B) ans = 0_I4B END PROCEDURE GetTotalInDOF_Line !---------------------------------------------------------------------------- From 48f68b7e06e569d441681cc44f054204baee1caf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 9 Oct 2025 10:50:58 +0900 Subject: [PATCH 073/184] Updating HierarchicalPolynomialUtility Minor updates in HierarchicalDOF --- .../src/HierarchicalPolynomialUtility@Methods.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 index 462fefdbf..4a9722da2 100644 --- a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -62,23 +62,27 @@ MODULE PROCEDURE HierarchicalDOF INTEGER(I4B) :: ii +LOGICAL(LGT) :: isok ans = 0 ii = HierarchicalVertexDOF(elemType=elemType) ans = ans + ii -IF (PRESENT(cellOrder)) THEN +isok = PRESENT(cellOrder) +IF (isok) THEN ii = HierarchicalCellDOF(elemType=elemType, order=cellOrder) ans = ans + ii END IF -IF (PRESENT(faceOrder)) THEN +isok = PRESENT(faceOrder) +IF (isok) THEN ii = HierarchicalFaceDOF(elemType=elemType, order=faceOrder) ans = ans + ii END IF -IF (PRESENT(edgeOrder)) THEN +isok = PRESENT(edgeOrder) +IF (isok) THEN ii = HierarchicalEdgeDOF(elemType=elemType, order=edgeOrder) ans = ans + ii END IF From 1ce64f9cc5665f701d11b328f6da42dd73a25936 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 9 Oct 2025 17:33:13 +0900 Subject: [PATCH 074/184] Adding Quadrangle Adding QuadrangleInterpolation and QuadrangleReferenceElement --- src/modules/CMakeLists.txt | 6 +- src/modules/Geometry/CMakeLists.txt | 57 +- .../Geometry/src/ReferenceElement_Method.F90 | 7 +- src/modules/Polynomial/CMakeLists.txt | 1 - src/modules/Quadrangle/CMakeLists.txt | 22 + .../src/QuadrangleInterpolationUtility.F90 | 2702 +++++++++-------- .../src/ReferenceQuadrangle_Method.F90 | 15 +- src/submodules/CMakeLists.txt | 3 + src/submodules/Geometry/CMakeLists.txt | 1 - src/submodules/Polynomial/CMakeLists.txt | 1 - ...QuadrangleInterpolationUtility@Methods.F90 | 2438 --------------- src/submodules/Quadrangle/CMakeLists.txt | 29 + ...drangleInterpolationUtility@DOFMethods.F90 | 49 + ...gleInterpolationUtility@DubinerMethods.F90 | 193 ++ ...terpolationUtility@HierarchicalMethods.F90 | 758 +++++ ...ationUtility@InterpolationPointMethods.F90 | 632 ++++ ...leInterpolationUtility@LagrangeMethods.F90 | 568 ++++ ...QuadrangleInterpolationUtility@Methods.F90 | 44 + ...InterpolationUtility@QuadratureMethods.F90 | 206 ++ ...InterpolationUtility@TensorProdMethods.F90 | 163 + .../ReferenceQuadrangle_Method@Methods.F90 | 89 +- 21 files changed, 4110 insertions(+), 3874 deletions(-) create mode 100644 src/modules/Quadrangle/CMakeLists.txt rename src/modules/{Polynomial => Quadrangle}/src/QuadrangleInterpolationUtility.F90 (92%) rename src/modules/{Geometry => Quadrangle}/src/ReferenceQuadrangle_Method.F90 (98%) delete mode 100644 src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Quadrangle/CMakeLists.txt create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90 create mode 100644 src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90 rename src/submodules/{Geometry => Quadrangle}/src/ReferenceQuadrangle_Method@Methods.F90 (91%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 396c467c6..c30b224d0 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,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt) # BaseContinuity include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt) +# Quadrangle +include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 8c398fbc6..8b6e08102 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -1,34 +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}/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}/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}/ReferenceTetrahedron_Method.F90 + ${src_path}/ReferenceHexahedron_Method.F90 + ${src_path}/ReferencePrism_Method.F90 + ${src_path}/ReferencePyramid_Method.F90 + ${src_path}/Geometry_Method.F90) + diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index 5e9e1d02c..a45ef8b15 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -135,8 +135,13 @@ MODULE ReferenceElement_Method 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 = & diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index e5c71feed..2ca278d11 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -30,7 +30,6 @@ target_sources( ${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 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 92% rename from src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 rename to src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index a272e1503..039021807 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -15,8 +15,12 @@ ! 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 @@ -87,7 +91,7 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -! GetTotalDOF_Quadrangle +! GetTotalDOF_Quadrangle@DOFMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -106,7 +110,7 @@ END FUNCTION GetTotalDOF_Quadrangle END INTERFACE !---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle +! LagrangeInDOF_Quadrangle@DOFMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -131,7 +135,7 @@ END FUNCTION GetTotalInDOF_Quadrangle1 END INTERFACE GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -! +! GetTotalInDOF_Quadrangle@DOFMethods !---------------------------------------------------------------------------- INTERFACE GetTotalInDOF_Quadrangle @@ -145,120 +149,7 @@ END FUNCTION GetTotalInDOF_Quadrangle2 END INTERFACE GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -! 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(*), 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 - -!---------------------------------------------------------------------------- -! QuadratureNumber_Quadrangle -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! 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 SUBROUTINE LagrangeDegree_Quadrangle1_(order, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(INOUT) :: ans(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeDegree_Quadrangle1_ -END INTERFACE LagrangeDegree_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE LagrangeDegree_Quadrangle - MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Quadrangle2 -END INTERFACE LagrangeDegree_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeDegree_Quadrangle_ - MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(INOUT) :: ans(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeDegree_Quadrangle2_ -END INTERFACE LagrangeDegree_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle +! LagrangeDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -274,7 +165,7 @@ END FUNCTION LagrangeDOF_Quadrangle1 END INTERFACE LagrangeDOF_Quadrangle !---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle +! LagrangeDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -291,7 +182,7 @@ END FUNCTION LagrangeDOF_Quadrangle2 END INTERFACE LagrangeDOF_Quadrangle !---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle +! LagrangeInDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -313,7 +204,7 @@ END FUNCTION LagrangeInDOF_Quadrangle1 END INTERFACE LagrangeInDOF_Quadrangle !---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle +! LagrangeInDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -335,851 +226,1044 @@ 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 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 !---------------------------------------------------------------------------- -! +! LagrangeDegree_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE EquidistancePoint_Quadrangle_ - MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle1_(order, & - ans, nrow, ncol, xij) +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE LagrangeDegree_Quadrangle_ + MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle1_(order, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order - !! 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(INOUT) :: ans(:, :) 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_ + END SUBROUTINE 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) +INTERFACE LagrangeDegree_Quadrangle + MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) 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 + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Quadrangle2 +END INTERFACE LagrangeDegree_Quadrangle !---------------------------------------------------------------------------- -! +! LagrangeDegree_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE EquidistancePoint_Quadrangle_ - MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle2_(p, q, ans, & - nrow, ncol, xij) +INTERFACE LagrangeDegree_Quadrangle_ + MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol) 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(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE EquidistancePoint_Quadrangle2_ -END INTERFACE EquidistancePoint_Quadrangle_ + END SUBROUTINE LagrangeDegree_Quadrangle2_ +END INTERFACE LagrangeDegree_Quadrangle_ !---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle +! LagrangeCoeff_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 EquidistanceInPoint_Quadrangle - MODULE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & - RESULT(ans) +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, 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 + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle1 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle +! LagrangeCoeff_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 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_ -INTERFACE EquidistanceInPoint_Quadrangle - MODULE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & 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 + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle2 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -!> 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 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_ -INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, & - xij, alpha, beta, lambda) RESULT(ans) +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) 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 + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle3 +END INTERFACE 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) + 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 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi 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 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle4 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle_ +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE InterpolationPoint_Quadrangle_ - MODULE SUBROUTINE InterpolationPoint_Quadrangle1_(order, ipType, ans, & - nrow, ncol, layout, xij, alpha, beta, lambda) +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, & + alpha, beta, lambda, ans, nrow, ncol) 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 + !! 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 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - END SUBROUTINE InterpolationPoint_Quadrangle1_ -END INTERFACE InterpolationPoint_Quadrangle_ + !! 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_ !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle +! LagrangeCoeff_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -!> 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) +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle5(p, q, xij, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p - !! order of element in x direction + !! order of polynomial 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 + !! order of polynomial in y direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basisType in x direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basisType in y direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! This parameter is needed when basisType is Jacobi + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION InterpolationPoint_Quadrangle2 -END INTERFACE InterpolationPoint_Quadrangle + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle5 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle_ +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE InterpolationPoint_Quadrangle_ - MODULE SUBROUTINE InterpolationPoint_Quadrangle2_(p, q, ipType1, ipType2, & - ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, & - alpha2, beta2, lambda2) +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 element in x direction + !! order of polynomial 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 + !! order of polynomial in y direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basisType in x direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basisType in y direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter + !! This parameter is needed when basisType is Ultraspherical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - END SUBROUTINE InterpolationPoint_Quadrangle2_ -END INTERFACE InterpolationPoint_Quadrangle_ + !! 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_ !---------------------------------------------------------------------------- -! IJ2VEFC +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Convert format from IJ to VEFC +! date: 2023-07-04 +! summary: Evaluate all Lagrange polynomial of order n at single points -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 +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 !---------------------------------------------------------------------------- -!> 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 +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-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 -!---------------------------------------------------------------------------- +! date: 2023-07-04 +! summary: Evaluate all Lagrange polynomials of order n at several points -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) +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 polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - REAL(DFP) :: ans(SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle1 -END INTERFACE LagrangeCoeff_Quadrangle + !! 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 !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle_ +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle1_(order, i, xij, ans, tsize) +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 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_ + !! 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_ !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! LagrangeGradientEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & - RESULT(ans) +!> 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 polynomial, it should be SIZE(v,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! coefficient for ith lagrange polynomial - REAL(DFP), INTENT(IN) :: v(:, :) - !! vandermonde matrix size should be (order+1,order+1) - LOGICAL(LGT), INTENT(IN) :: isVandermonde - !! This is just to resolve interface issue - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle2 -END INTERFACE LagrangeCoeff_Quadrangle + !! 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 !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle_ +! LagrangeGradientEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle2_(order, i, v, isVandermonde, & - ans, tsize) +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 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_ + !! 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_ !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! RefElemDomain_Quadrangle@Methods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, it should be SIZE(x,2)-1 - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(INOUT) :: v(:, :) - !! LU decomposition of vandermonde matrix - INTEGER(I4B), INTENT(IN) :: ipiv(:) - !! inverse pivoting mapping, compes from LU decomposition - REAL(DFP) :: ans(SIZE(v, 1)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle3 -END INTERFACE LagrangeCoeff_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@Methods !---------------------------------------------------------------------------- -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_ +!> 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 !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! EquidistancePoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - 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(:, :) - !! 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) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle4 -END INTERFACE LagrangeCoeff_Quadrangle - -!---------------------------------------------------------------------------- +!> 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 LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, & - alpha, beta, lambda, ans, nrow, ncol) +INTERFACE EquidistancePoint_Quadrangle + MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & + 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 ! 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 + !! 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(:, :) - !! ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients + !! 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 LagrangeCoeff_Quadrangle4_ -END INTERFACE LagrangeCoeff_Quadrangle_ + !! 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_ !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! EquidistancePoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle5(p, q, xij, basisType1, & - basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) +!> 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 of polynomial in x direction + !! order in x direction INTEGER(I4B), INTENT(IN) :: q - !! order of polynomial in y direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - INTEGER(I4B), INTENT(IN) :: basisType1 - !! basisType in x direction - !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! basisType in y direction - !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! This parameter is needed when basisType is Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! This parameter is needed when basisType is Ultraspherical - REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle5 -END INTERFACE LagrangeCoeff_Quadrangle + !! 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 LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle5_(p, q, xij, basisType1, & - basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2, & - ans, nrow, ncol) +INTERFACE EquidistancePoint_Quadrangle_ + MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle2_(p, q, ans, & + nrow, ncol, xij) INTEGER(I4B), INTENT(IN) :: p - !! order of polynomial in x direction + !! order in x direction INTEGER(I4B), INTENT(IN) :: q - !! order of polynomial in y direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) - INTEGER(I4B), INTENT(IN) :: basisType1 - !! basisType in x direction - !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical - !! Heirarchical - INTEGER(I4B), INTENT(IN) :: basisType2 - !! basisType in y direction - !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! This parameter is needed when basisType is Ultraspherical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! This parameter is needed when basisType is Jacobi - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! This parameter is needed when basisType is Ultraspherical + !! 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(:, :) - ! ans(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficients + !! 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 LagrangeCoeff_Quadrangle5_ -END INTERFACE LagrangeCoeff_Quadrangle_ + END SUBROUTINE EquidistancePoint_Quadrangle2_ +END INTERFACE EquidistancePoint_Quadrangle_ !---------------------------------------------------------------------------- -! DubinerPolynomial +! EquidistanceInPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 14 Aug 2022 +! summary: Returns equidistance points in Quadrangle ! !# 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} -!$$ +!- 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 ! -! For example for order=3, the polynomials are arranged as: +!# Introduction ! -!$$ -! 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} -!$$ +!- This function returns the equidistance points in Quadrangle +!- All points are inside the Quadrangle -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 +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 !---------------------------------------------------------------------------- -! DubinerPolynomial +! InterpolationPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 18 Aug 2022 +! summary: Interpolation point ! !# Introduction ! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is called while forming dubiner basis on triangle domain +! In this case order is same in both x1 and x2 direction. Therefore, +! (N+1)**2 grid points are returned. ! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). +! Also in both x1 and x2 same type of grid family will be used. ! -! In this way, ans(j,:) denotes the values of all polynomial at jth point +!- 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 ! -! Polynomials are returned in following way: +!- `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. ! -!$$ -! 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} -!$$ +! interpolation point type +! Equidistance +! GaussLegendre +! GaussLegendreLobatto +! GaussLegendreRadauLeft +! GaussLegendreRadauRight +! GaussChebyshev1 +! GaussChebyshev1Lobatto +! GaussChebyshev1RadauLeft +! GaussChebyshev1RadauRight +! GaussUltraspherical +! GaussUltrasphericalLobatto +! GaussUltrasphericalRadauLeft +! GaussUltrasphericalRadauRight +! GaussJacobi +! GaussJacobiLobatto +! GaussJacobiRadauLeft +! GaussJacobiRadauRight -INTERFACE Dubiner_Quadrangle_ - MODULE PURE SUBROUTINE Dubiner_Quadrangle1_(order, xij, ans, nrow, ncol) +INTERFACE InterpolationPoint_Quadrangle + MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, & + xij, alpha, beta, lambda) 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 + !! 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(:, :) - ! 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 + !! INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE Dubiner_Quadrangle1_ -END INTERFACE Dubiner_Quadrangle_ + 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_ !---------------------------------------------------------------------------- -! DubinerPolynomial +! InterpolationPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 18 Aug 2022 +! summary: Interpolation point ! !# Introduction ! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is same as Dubiner_Quadrangle1 -! The only difference is that xij are given by outerproduct of x and y. -! This function calls `Dubiner_Quadrangle1`. +! 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 Dubiner_Quadrangle - MODULE PURE FUNCTION Dubiner_Quadrangle2(order, x, y) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: x(:) - !! x coordinate on line - REAL(DFP), INTENT(IN) :: y(:) - !! y coordinate on line - REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION Dubiner_Quadrangle2 -END INTERFACE Dubiner_Quadrangle +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 !---------------------------------------------------------------------------- -! DubinerPolynomial +! InterpolationPoint_Quadrangle_@InterpolationPointMethods !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain -! -!# Introduction -! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is same as Dubiner_Quadrangle1 -! The only difference is that xij are given by outerproduct of x and y. -! This function calls `Dubiner_Quadrangle1`. - -INTERFACE Dubiner_Quadrangle_ - MODULE PURE SUBROUTINE Dubiner_Quadrangle2_(order, x, y, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: x(:) - !! x coordinate on line - REAL(DFP), INTENT(IN) :: y(:) - !! y coordinate on line +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(:, :) - ! ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point + !! INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE Dubiner_Quadrangle2_ -END INTERFACE Dubiner_Quadrangle_ + !! + 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 !---------------------------------------------------------------------------- -! DubinerGradient +! DubinerPolynomial@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1215,8 +1299,174 @@ END SUBROUTINE Dubiner_Quadrangle2_ ! P_{3,0} !$$ -INTERFACE DubinerGradient_Quadrangle - MODULE PURE FUNCTION DubinerGradient_Quadrangle1(order, xij) RESULT(ans) +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@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 SUBROUTINE Dubiner_Quadrangle1_(order, xij, ans, nrow, ncol) + 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), INTENT(INOUT) :: ans(:, :) + ! 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 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Dubiner_Quadrangle1_ +END INTERFACE Dubiner_Quadrangle_ + +!---------------------------------------------------------------------------- +! 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 same as Dubiner_Quadrangle1 +! The only difference is that xij are given by outerproduct of x and y. +! This function calls `Dubiner_Quadrangle1`. + +INTERFACE Dubiner_Quadrangle + MODULE PURE FUNCTION Dubiner_Quadrangle2(order, x, y) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:) + !! x coordinate on line + REAL(DFP), INTENT(IN) :: y(:) + !! y coordinate on line + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Quadrangle2 +END INTERFACE Dubiner_Quadrangle + +!---------------------------------------------------------------------------- +! 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 same as Dubiner_Quadrangle1 +! The only difference is that xij are given by outerproduct of x and y. +! This function calls `Dubiner_Quadrangle1`. + +INTERFACE Dubiner_Quadrangle_ + MODULE PURE SUBROUTINE Dubiner_Quadrangle2_(order, x, y, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:) + !! x coordinate on line + REAL(DFP), INTENT(IN) :: y(:) + !! y coordinate on line + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Dubiner_Quadrangle2_ +END INTERFACE Dubiner_Quadrangle_ + +!---------------------------------------------------------------------------- +! DubinerGradient@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 DubinerGradient_Quadrangle + MODULE PURE FUNCTION DubinerGradient_Quadrangle1(order, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomial space REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1232,7 +1482,7 @@ END FUNCTION DubinerGradient_Quadrangle1 END INTERFACE DubinerGradient_Quadrangle !---------------------------------------------------------------------------- -! DubinerGradient +! DubinerGradient@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1289,7 +1539,7 @@ END SUBROUTINE DubinerGradient_Quadrangle1_ END INTERFACE DubinerGradient_Quadrangle_ !---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle +! TensorProdBasis_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1340,7 +1590,7 @@ END FUNCTION TensorProdBasis_Quadrangle1 END INTERFACE OrthogonalBasis_Quadrangle !---------------------------------------------------------------------------- -! +! TensorProdBasis_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- INTERFACE TensorProdBasis_Quadrangle_ @@ -1382,7 +1632,7 @@ END SUBROUTINE TensorProdBasis_Quadrangle1_ END INTERFACE OrthogonalBasis_Quadrangle_ !---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle +! TensorProdBasis_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1444,7 +1694,7 @@ END FUNCTION TensorProdBasis_Quadrangle2 END INTERFACE OrthogonalBasis_Quadrangle !---------------------------------------------------------------------------- -! +! TensorProdBasis_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- INTERFACE TensorProdBasis_Quadrangle_ @@ -1489,7 +1739,7 @@ END SUBROUTINE TensorProdBasis_Quadrangle2_ END INTERFACE OrthogonalBasis_Quadrangle_ !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1506,7 +1756,7 @@ END FUNCTION VertexBasis_Quadrangle1 END INTERFACE VertexBasis_Quadrangle !---------------------------------------------------------------------------- -! +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE VertexBasis_Quadrangle_ @@ -1521,7 +1771,7 @@ END SUBROUTINE VertexBasis_Quadrangle1_ END INTERFACE VertexBasis_Quadrangle_ !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1538,7 +1788,7 @@ END FUNCTION VertexBasis_Quadrangle2 END INTERFACE VertexBasis_Quadrangle !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE VertexBasis_Quadrangle_ @@ -1553,7 +1803,7 @@ END SUBROUTINE VertexBasis_Quadrangle2_ END INTERFACE VertexBasis_Quadrangle_ !---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle +! VerticalEdgeBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1585,7 +1835,7 @@ END FUNCTION VerticalEdgeBasis_Quadrangle END INTERFACE !---------------------------------------------------------------------------- -! +! VerticalEdgeBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE @@ -1607,7 +1857,7 @@ END SUBROUTINE VerticalEdgeBasis_Quadrangle_ END INTERFACE !---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle +! HorizontalEdgeBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1621,7 +1871,8 @@ END SUBROUTINE VerticalEdgeBasis_Quadrangle_ ! pe3 and pe4 should be greater than or equal to 2 INTERFACE - MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) RESULT(ans) + MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: pe3 !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: pe4 @@ -1652,7 +1903,7 @@ END SUBROUTINE HorizontalEdgeBasis_Quadrangle_ END INTERFACE !---------------------------------------------------------------------------- -! CellBasis_Quadrangle +! CellBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1676,7 +1927,7 @@ END FUNCTION CellBasis_Quadrangle END INTERFACE !---------------------------------------------------------------------------- -! +! CellBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE @@ -1695,7 +1946,7 @@ END SUBROUTINE CellBasis_Quadrangle_ END INTERFACE !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! HeirarchicalBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1738,7 +1989,7 @@ END FUNCTION HeirarchicalBasis_Quadrangle1 END INTERFACE HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- -! +! HeirarchicalBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasis_Quadrangle_ @@ -1766,7 +2017,7 @@ END SUBROUTINE HeirarchicalBasis_Quadrangle1_ END INTERFACE HeirarchicalBasis_Quadrangle_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! HeirarchicalBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1792,7 +2043,7 @@ END FUNCTION HeirarchicalBasis_Quadrangle2 END INTERFACE HeirarchicalBasis_Quadrangle !---------------------------------------------------------------------------- -! +! HeirarchicalBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasis_Quadrangle_ @@ -1812,552 +2063,84 @@ 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE HeirarchicalBasis_Quadrangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle3_(pb, qb, pe3, pe4, & - qe1, qe2, xij, pe3Orient, pe4Orient, qe1Orient, qe2Orient, & - faceOrient, ans, nrow, ncol) + 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), INTENT(INOUT) :: ans(:, :) - !! nrow = SIZE(xij, 2), & - !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE HeirarchicalBasis_Quadrangle3_ -END INTERFACE HeirarchicalBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-04 -! summary: Evaluate all Lagrange polynomial of order n at single points - -INTERFACE LagrangeEvalAll_Quadrangle - MODULE FUNCTION LagrangeEvalAll_Quadrangle1(order, x, xij, coeff, & - firstCall, basisType, alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(2) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - !! The number of rows in xij can be 2 or 3 - !! The number of columns in xij should be equal to total - !! degree of freedom - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be computed and returned - !! by this routine. - !! If firstCall is False, then coeff should be given, which will be - !! used. - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Quadrangle1 -END INTERFACE LagrangeEvalAll_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeEvalAll_Quadrangle_ - MODULE SUBROUTINE LagrangeEvalAll_Quadrangle1_(order, x, xij, ans, tsize, & - coeff, firstCall, basisType, alpha, beta, lambda) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(2) - !! point of evaluation - !! x(1) is x coord - !! x(2) is y coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - !! The number of rows in xij can be 2 or 3 - !! The number of columns in xij should be equal to total - !! degree of freedom - REAL(DFP), INTENT(INOUT) :: ans(:) - !! ans(SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - INTEGER(I4B), INTENT(OUT) :: tsize - !! Total size written in ans - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) - !! coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be computed and returned - !! by this routine. - !! If firstCall is False, then coeff should be given, which will be - !! used. - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Legendre - !! Lobatto - !! Chebyshev - !! Jacobi - !! Ultraspherical - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - END SUBROUTINE LagrangeEvalAll_Quadrangle1_ -END INTERFACE LagrangeEvalAll_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeEvalAll_Quadrangle_ - MODULE SUBROUTINE LagrangeEvalAll_Quadrangle2_(order, x, xij, ans, & - nrow, ncol, coeff, firstCall, basisType, alpha, beta, lambda) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! Point of evaluation - !! x(1, :) is x coord - !! x(2, :) is y coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written in ans - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) - !! coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Jacobi=Dubiner - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - END SUBROUTINE LagrangeEvalAll_Quadrangle2_ -END INTERFACE LagrangeEvalAll_Quadrangle_ - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points on reference quadrangle - -INTERFACE QuadraturePoint_Quadrangle - 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 - 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 QuadraturePoint_Quadrangle1 -END INTERFACE QuadraturePoint_Quadrangle - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE QuadraturePoint_Quadrangle - 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 - CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle ! UNIT ! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION QuadraturePoint_Quadrangle2 -END INTERFACE QuadraturePoint_Quadrangle - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points on reference quadrangle - -INTERFACE QuadraturePoint_Quadrangle - MODULE FUNCTION QuadraturePoint_Quadrangle3(nips, quadType, & - 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 - 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) :: 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 QuadraturePoint_Quadrangle3 -END INTERFACE QuadraturePoint_Quadrangle - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -INTERFACE QuadraturePoint_Quadrangle - 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 - CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle ! UNIT ! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION QuadraturePoint_Quadrangle4 -END INTERFACE QuadraturePoint_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE QuadraturePoint_Quadrangle_ - MODULE SUBROUTINE QuadraturePoint_Quadrangle1_(nipsx, nipsy, quadType1, & - quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, & - lambda2, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! order of integrand in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! order of integrand in y direction - INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 - !! interpolation point type in x direction - !! Equidistance ! GaussLegendre ! GaussLegendreLobatto - !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 - !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight ! GaussUltraspherical - !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight ! GaussJacobi - !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle ! UNIT ! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! interpolation points in xij format - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written in ans - END SUBROUTINE QuadraturePoint_Quadrangle1_ -END INTERFACE QuadraturePoint_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -!> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -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_ + !! 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_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2398,7 +2181,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle1 END INTERFACE HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Quadrangle_ @@ -2427,7 +2210,7 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle1_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2447,7 +2230,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle2 END INTERFACE HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Quadrangle_ @@ -2468,7 +2251,7 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- -! +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2508,7 +2291,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle3 END INTERFACE HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Quadrangle_ @@ -2548,7 +2331,7 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle3_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- -! TensorProdBasisGradient_Quadrangle +! TensorProdBasisGradient_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2595,7 +2378,7 @@ END FUNCTION TensorProdBasisGradient_Quadrangle1 END INTERFACE OrthogonalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! +! TensorProdBasisGradient_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- INTERFACE TensorProdBasisGradient_Quadrangle_ @@ -2641,4 +2424,223 @@ END SUBROUTINE TensorProdBasisGradient_Quadrangle1_ 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@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) + INTEGER(I4B), INTENT(IN) :: order + !! Order of integrand in x and y direction + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + 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) :: 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 QuadraturePoint_Quadrangle1 +END INTERFACE 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) + 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, see above + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Quadrangle2 +END INTERFACE QuadraturePoint_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points on reference quadrangle + +INTERFACE QuadraturePoint_Quadrangle + MODULE FUNCTION QuadraturePoint_Quadrangle3(nips, quadType, & + 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, see above + 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) :: 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 QuadraturePoint_Quadrangle3 +END INTERFACE 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) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 + !! interpolation point type in x direction + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Quadrangle4 +END INTERFACE QuadraturePoint_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Quadrangle_ + MODULE SUBROUTINE QuadraturePoint_Quadrangle1_(nipsx, nipsy, quadType1, & + quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 + !! interpolation point type in x direction + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + END SUBROUTINE QuadraturePoint_Quadrangle1_ +END INTERFACE QuadraturePoint_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE QuadrangleInterpolationUtility diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90 similarity index 98% rename from src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 rename to src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90 index 741d12967..fa8360e5f 100644 --- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 +++ b/src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90 @@ -21,7 +21,6 @@ MODULE ReferenceQuadrangle_Method USE GlobalData, ONLY: DFP, I4B, LGT - USE BaseType, ONLY: ReferenceQuadrangle_, ReferenceElement_, & ReferenceTopology_ @@ -61,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 diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index c6af0f192..2f7126a86 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -27,6 +27,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) # Utility include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) +# Quadrangle +include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index 74342d10f..0d5c9d2cf 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -32,7 +32,6 @@ target_sources( ${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 diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 8cdab8754..c200641b1 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -26,7 +26,6 @@ target_sources( ${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 diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 deleted file mode 100644 index e837b8026..000000000 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,2438 +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 LineInterpolationUtility, ONLY: QuadratureNumber_Line, & - InterpolationPoint_Line_, & - BasisEvalAll_Line_, & - BasisGradientEvalAll_Line_, & - QuadraturePoint_Line_ -USE ReallocateUtility, ONLY: Reallocate -USE MappingUtility, ONLY: FromBiUnitQuadrangle2Quadrangle_, & - FromBiUnitQuadrangle2UnitQuadrangle_, & - JacobianQuadrangle -USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ -USE GE_LUMethods, ONLY: GetLU, LUSolve -USE InputUtility, ONLY: Input -USE LegendrePolynomialUtility, ONLY: LegendreEvalAll_, & - LegendreGradientEvalAll_ -USE JacobiPolynomialUtility, ONLY: JacobiEvalAll_, & - JacobiGradientEvalAll_ -USE LobattoPolynomialUtility, ONLY: LobattoEvalAll_, & - LobattoGradientEvalAll_ -USE ErrorHandling, ONLY: Errormsg -USE F95_BLAS, ONLY: GEMM -USE StringUtility, ONLY: UpperCase -USE GE_CompRoutineMethods, ONLY: GetInvMat - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Quadrangle -ans = "BIUNIT" -END PROCEDURE RefElemDomain_Quadrangle - -!---------------------------------------------------------------------------- -! FacetConnectivity -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! 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) :: nrow, ncol -nrow = LagrangeDOF_Quadrangle(order=order) -ALLOCATE (ans(nrow, 2)) -CALL LagrangeDegree_Quadrangle1_(ans=ans, nrow=nrow, ncol=ncol, order=order) -END PROCEDURE LagrangeDegree_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle1_ -CALL LagrangeDegree_Quadrangle2_(ans=ans, p=order, q=order, nrow=nrow, & - ncol=ncol) -END PROCEDURE LagrangeDegree_Quadrangle1_ - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle2 -INTEGER(I4B) :: nrow, ncol - -nrow = LagrangeDOF_Quadrangle(p=p, q=q) -ALLOCATE (ans(nrow, 2)) -CALL LagrangeDegree_Quadrangle2_(ans=ans, nrow=nrow, ncol=ncol, & - p=p, q=q) -END PROCEDURE LagrangeDegree_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle2_ -INTEGER(I4B) :: ii, jj, p1 - -nrow = LagrangeDOF_Quadrangle(p=p, q=q) -ncol = 2 -p1 = p + 1 - -DO CONCURRENT(jj=0:q, ii=0:p) - ans(p1 * jj + ii + 1, 1) = ii - ans(p1 * jj + ii + 1, 2) = jj -END DO - -END PROCEDURE LagrangeDegree_Quadrangle2_ - -!---------------------------------------------------------------------------- -! GetTotalDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Quadrangle -ans = (order + 1)**2 -END PROCEDURE GetTotalDOF_Quadrangle - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Quadrangle -!---------------------------------------------------------------------------- - -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 - -!---------------------------------------------------------------------------- -! 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) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2_I4B -END IF - -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=Equidistance, ipType2=Equidistance, ans=ans, & - nrow=nrow, ncol=ncol, layout="VEFC", xij=xij) -END PROCEDURE EquidistancePoint_Quadrangle2_ - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Quadrangle1 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2 -END IF - -ncol = LagrangeInDOF_Quadrangle(order=order) - -IF (ncol .EQ. 0) THEN - ALLOCATE (ans(0, 0)) - RETURN -ELSE - ALLOCATE (ans(nrow, ncol)) - ans(1:nrow, 1:ncol) = EquidistanceInPoint_Quadrangle2(p=order, q=order, & - xij=xij) -END IF -END PROCEDURE EquidistanceInPoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Quadrangle2 -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: a, b, nrow, ncol - -a = LagrangeDOF_Quadrangle(p=p, q=q) -b = LagrangeInDOF_Quadrangle(p=p, q=q) - -IF (PRESENT(xij)) 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, & - pointsOrder, startNode) - INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) - INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) - INTEGER(I4B), INTENT(IN) :: startNode - - SELECT CASE (startNode) - CASE (1) - edgeConnectivity(1:2, 1) = [1, 2] - edgeConnectivity(1:2, 2) = [2, 3] - edgeConnectivity(1:2, 3) = [3, 4] - edgeConnectivity(1:2, 4) = [4, 1] - pointsOrder = [1, 2, 3, 4] - CASE (2) - edgeConnectivity(1:2, 1) = [2, 3] - edgeConnectivity(1:2, 2) = [3, 4] - edgeConnectivity(1:2, 3) = [4, 1] - edgeConnectivity(1:2, 4) = [1, 2] - pointsOrder = [2, 3, 4, 1] - CASE (3) - edgeConnectivity(1:2, 1) = [3, 4] - edgeConnectivity(1:2, 2) = [4, 1] - edgeConnectivity(1:2, 3) = [1, 2] - edgeConnectivity(1:2, 4) = [2, 3] - pointsOrder = [3, 4, 1, 2] - CASE (4) - edgeConnectivity(1:2, 1) = [4, 1] - edgeConnectivity(1:2, 2) = [1, 2] - edgeConnectivity(1:2, 3) = [2, 3] - edgeConnectivity(1:2, 4) = [3, 4] - pointsOrder = [4, 1, 2, 3] - END SELECT - -END SUBROUTINE GetEdgeConnectivityHelpAntiClock - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, & - startNode) - INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) - INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) - INTEGER(I4B), INTENT(IN) :: startNode - - SELECT CASE (startNode) - CASE (1) - edgeConnectivity(1:2, 1) = [1, 4] - edgeConnectivity(1:2, 2) = [4, 3] - edgeConnectivity(1:2, 3) = [3, 2] - edgeConnectivity(1:2, 4) = [2, 1] - pointsOrder = [1, 4, 3, 2] - CASE (2) - edgeConnectivity(1:2, 1) = [2, 1] - edgeConnectivity(1:2, 2) = [1, 4] - edgeConnectivity(1:2, 3) = [4, 3] - edgeConnectivity(1:2, 4) = [3, 2] - pointsOrder = [2, 1, 4, 3] - CASE (3) - edgeConnectivity(1:2, 1) = [3, 2] - edgeConnectivity(1:2, 2) = [2, 1] - edgeConnectivity(1:2, 3) = [1, 4] - edgeConnectivity(1:2, 4) = [4, 3] - pointsOrder = [3, 2, 1, 4] - CASE (4) - edgeConnectivity(1:2, 1) = [4, 3] - edgeConnectivity(1:2, 2) = [3, 2] - edgeConnectivity(1:2, 3) = [2, 1] - edgeConnectivity(1:2, 4) = [1, 4] - pointsOrder = [4, 3, 2, 1] - END SELECT - -END SUBROUTINE GetEdgeConnectivityHelpClock - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise -! internal variables -INTEGER(I4B) :: cnt, 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_ - -!---------------------------------------------------------------------------- -! 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 -! V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Quadrangle, ans=V, & - nrow=nrow, ncol=ncol) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans(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=Monomial, option=basisType) - -IF (basisType0 .EQ. Heirarchical) 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) - -basisType(1) = Input(default=Monomial, option=basisType1) -basisType(2) = Input(default=Monomial, option=basisType2) - -IF (ALL(basisType .EQ. Heirarchical)) 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 - -! ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=p, q=q, xij=xij, & -CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, & - basisType1=basisType(1), alpha1=alpha1, beta1=beta1, lambda1=lambda1, & - basisType2=basisType(2), alpha2=alpha2, beta2=beta2, lambda2=lambda2, & - ans=ans, nrow=nrow, ncol=ncol) - -CALL GetInvMat(ans(1:nrow, 1:ncol)) - -END PROCEDURE LagrangeCoeff_Quadrangle5_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -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_ -#define TP size(xij, 2) - -REAL(DFP) :: P1(TP, order + 1), P2(TP, order + 1), temp(TP, 3) - -REAL(DFP) :: alpha, beta - -INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii - -#undef TP - -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_ - -!---------------------------------------------------------------------------- -! 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_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL TensorProdBasis_Quadrangle2_(p=p, q=q, x=x, y=y, ans=ans, nrow=nrow, & - ncol=ncol, basisType1=basisType1, basisType2=basisType2, & - alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & - beta2=beta2, lambda2=lambda2) -END PROCEDURE TensorProdBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle2_ -REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) -INTEGER(I4B) :: ii, jj - -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_ - -!---------------------------------------------------------------------------- -! 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_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE VertexBasis_Quadrangle3_(L1, L2, ans, nrow, ncol) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), 4) - !! ans(:,v1) basis function of vertex v1 at all points - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - - !! internal variable - INTEGER(I4B) :: ii - - nrow = SIZE(L1, 1) - ncol = 4 - - DO CONCURRENT(ii=1:nrow) - ans(ii, 1) = L1(ii, 0) * L2(ii, 0) - ans(ii, 2) = L1(ii, 1) * L2(ii, 0) - ans(ii, 3) = L1(ii, 1) * L2(ii, 1) - ans(ii, 4) = L1(ii, 0) * L2(ii, 1) - END DO -END SUBROUTINE VertexBasis_Quadrangle3_ - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle2 -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_ - -!---------------------------------------------------------------------------- -! 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(:, :) - -maxQ = MAX(qe1, qe2) - -aint = SIZE(y) -nrow = SIZE(x) -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) - -CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans, & - nrow=nrow, ncol=ncol, qe1Orient=orient, qe2Orient=orient) - -DEALLOCATE (L2, L1) - -END PROCEDURE VerticalEdgeBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, & - ans, nrow, ncol, qe1Orient, qe2Orient) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), qe1 + qe2 - 2) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written to ans - INTEGER(I4B), INTENT(IN), OPTIONAL :: qe1Orient, qe2Orient - !! orientation fo left and write vertical edge - !! it can be 1 or -1 - - INTEGER(I4B) :: k2, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(-qe1Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & - ! in master element - o2 = REAL(qe2Orient, kind=DFP) - - nrow = SIZE(L1, 1) - ncol = qe1 + qe2 - 2 - cnt = qe1 - 1 - - !! left vertical - DO CONCURRENT(k2=2:qe1, ii=1:nrow) - ans(ii, k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2) - END DO - - !! right vertical - DO CONCURRENT(k2=2:qe2, ii=1:nrow) - ans(ii, cnt + k2 - 1) = (o2**k2) * L1(ii, 1) * L2(ii, k2) - END DO - -END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! VerticalEdgeBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3, qe1Orient, qe2Orient) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - !! dim1=SIZE(L1, 1) - !! dim2=qe1 + qe2 - 2 - !! dim3= 2 - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! range of data written to ans - INTEGER(I4B), INTENT(IN) :: qe1Orient, qe2Orient - !! orientation fo left and write vertical edge - !! it can be 1 or -1 - - INTEGER(I4B) :: k2, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(-qe1Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & - ! in master element - o2 = REAL(qe2Orient, kind=DFP) - - dim1 = SIZE(L1, 1) - dim2 = qe1 + qe2 - 2 - dim3 = 2 - - cnt = qe1 - 1 - - DO CONCURRENT(k2=2:qe1, ii=1:dim1) - ans(ii, k2 - 1, 1) = (o1**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2) - ans(ii, k2 - 1, 2) = (o1**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2) - END DO - - DO CONCURRENT(k2=2:qe2, ii=1:dim1) - ans(ii, cnt + k2 - 1, 1) = (o2**(k2 - 1)) * dL1(ii, 1) * L2(ii, k2) - ans(ii, cnt + k2 - 1, 2) = (o2**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2) - END DO - -END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle -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) -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) - -CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans, nrow=nrow, ncol=ncol, pe3Orient=orient, pe4Orient=orient) - -DEALLOCATE (L1, L2) - -END PROCEDURE HorizontalEdgeBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle2_(pe3, pe4, L1, L2, & - ans, nrow, ncol, pe3Orient, pe4Orient) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), pe3 + pe4 - 2) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written to ans - INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient - !! orientaion of bottom and top edge - - INTEGER(I4B) :: k1, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(pe3Orient, kind=DFP) - - o2 = REAL(-pe4Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & - ! in master element - - nrow = SIZE(L1, 1) - ncol = pe3 + pe4 - 2 - cnt = pe3 - 1 - - !! bottom edge - DO CONCURRENT(k1=2:pe3, ii=1:nrow) - ans(ii, k1 - 1) = (o1**k1) * L1(ii, k1) * L2(ii, 0) - END DO - - !! top edge - DO CONCURRENT(k1=2:pe4, ii=1:nrow) - ans(ii, cnt + k1 - 1) = (o2**k1) * L1(ii, k1) * L2(ii, 1) - END DO - -END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3, pe3Orient, pe4Orient) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! dim1 = SIZE(L1, 1) - !! dim2 = pe3 + pe4 - 2 - !! dim3 = 2 - INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient - !! orientation of bottom and top horizontal edge - - !! internal variable - INTEGER(I4B) :: k1, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(pe3Orient, kind=DFP) - - o2 = REAL(-pe4Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & - ! in master element - - dim1 = SIZE(L1, 1) - dim2 = pe3 + pe4 - 2 - dim3 = 2 - cnt = pe3 - 1 - - !! bottom edge - DO CONCURRENT(k1=2:pe3, ii=1:dim1) - ans(ii, k1 - 1, 1) = (o1**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0) - ans(ii, k1 - 1, 2) = (o1**(k1 - 1)) * L1(ii, k1) * dL2(ii, 0) - END DO - - !! top edge - DO CONCURRENT(k1=2:pe4, ii=1:dim1) - ans(ii, cnt + k1 - 1, 1) = (o2**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1) - ans(ii, cnt + k1 - 1, 2) = (o2**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1) - END DO - -END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle -INTEGER(I4B) :: nrow, ncol -CALL CellBasis_Quadrangle_(pb=pb, qb=qb, x=x, y=y, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE CellBasis_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle_ -REAL(DFP) :: L1(1:SIZE(x), 0:pb) -REAL(DFP) :: L2(1:SIZE(y), 0:qb) -INTEGER(I4B), 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) - -END PROCEDURE CellBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & - faceOrient) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and cols written to ans - INTEGER(I4B), INTENT(IN) :: faceOrient(3) - !! face orientation - - !! Internal variables - INTEGER(I4B) :: k1, k2, ii, p, q - REAL(DFP) :: o1, o2 - - nrow = SIZE(L1, 1) - ncol = (pb - 1) * (qb - 1) - - o1 = REAL(faceOrient(1), kind=DFP) - o2 = REAL(faceOrient(2), kind=DFP) - - IF (faceOrient(3) .LT. 0_I4B) THEN - p = qb - q = pb - ELSE - p = pb - q = qb - END IF - - DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) - ans(ii, (q - 1) * (k1 - 2) + k2 - 1) = & - (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2) - END DO - -END SUBROUTINE CellBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! CellBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & - dL1, dL2, ans, dim1, dim2, dim3, faceOrient) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! dim1=SIZE(L1, 1) - !! dim2=(pb - 1) * (qb - 1) - !! dim3=2 - INTEGER(I4B), INTENT(IN) :: faceOrient(3) - - !! internal variables - INTEGER(I4B) :: k1, k2, ii, p, q - REAL(DFP) :: o1, o2 - - dim1 = SIZE(L1, 1) - dim2 = (pb - 1) * (qb - 1) - dim3 = 2 - - o1 = REAL(faceOrient(1), kind=DFP) - o2 = REAL(faceOrient(2), kind=DFP) - - IF (faceOrient(3) .LT. 0_I4B) THEN - p = qb - q = pb - ELSE - p = pb - q = qb - END IF - - DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1) - - ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 1) = & - (o1**(k1 - 1)) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) - - ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 2) = & - (o1**k1) * (o2**(k2 - 1)) * L1(ii, k1) * dL2(ii, k2) - - END DO - -END SUBROUTINE CellBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ -INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] -CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, & - qe2=qe2, xij=xij, pe3Orient=orient, pe4Orient=orient, & - qe1Orient=orient, qe2Orient=orient, faceOrient=faceOrient, ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle1_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol - -CALL HeirarchicalBasis_Quadrangle1_(pb=p, pe3=p, pe4=p, & - qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle2_ -CALL HeirarchicalBasis_Quadrangle1_(pb=p, pe3=p, pe4=p, & - qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle3 -INTEGER(I4B) :: nrow, ncol - -nrow = SIZE(xij, 2) -ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 - -ALLOCATE (ans(1:nrow, 1:ncol)) - -CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, pe3Orient=pe3Orient, pe4Orient=pe4Orient, & - qe1Orient=qe1Orient, qe2Orient=qe2Orient, faceOrient=faceOrient, & - ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE HeirarchicalBasis_Quadrangle3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_ -INTEGER(I4B) :: 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) - -! Edge basis function -isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) -IF (isok) THEN - CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), qe1Orient=qe1Orient, & - qe2Orient=qe2Orient) - - ncol = ncol + indx(2) -END IF - -! Edge basis function -isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) -IF (isok) THEN - CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), pe3Orient=pe3Orient, & - pe4Orient=pe4Orient) - ncol = ncol + indx(2) -END IF - -! Cell basis function -isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) -IF (isok) THEN - CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient) - ncol = ncol + indx(2) -END IF - -DEALLOCATE (L1, L2) - -END PROCEDURE HeirarchicalBasis_Quadrangle3_ - -!---------------------------------------------------------------------------- -! LagrangeEvallAll_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle1 -INTEGER(I4B) :: tsize -CALL LagrangeEvalAll_Quadrangle1_(order=order, x=x, xij=xij, & - ans=ans, tsize=tsize, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE LagrangeEvalAll_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle1_ -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, degree(SIZE(xij, 2), 2), indx(2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & - x21(2, 1) - -tsize = SIZE(xij, 2) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - 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 (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 (Heirarchical) - - ! 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) :: firstCall0 -INTEGER(I4B) :: ii, jj, basisType0, indx(2), degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) ,xx(SIZE(x, 2), SIZE(xij, 2)), & - aval - -nrow = SIZE(x, 2) -ncol = SIZE(xij, 2) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - - ! coeff = LagrangeCoeff_Quadrangle(& - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff, nrow=indx(1), ncol=indx(2)) - END IF - - coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) - -ELSE - - ! coeff0 = LagrangeCoeff_Quadrangle(& - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & - nrow=indx(1), ncol=indx(2)) - -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - ! degree = LagrangeDegree_Quadrangle(order=order) - CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & - ncol=indx(2)) - -#ifdef DEBUG_VER - IF (ncol .NE. SIZE(degree, 1)) THEN - CALL Errormsg(msg="tdof is not same as size(degree,1)", & - routine="LagrangeEvalAll_Quadrangle1", file=__FILE__, line=__LINE__, & - unitno=stderr) - RETURN - END IF -#endif - - DO ii = 1, ncol - indx(1:2) = degree(ii, 1:2) - DO jj = 1, nrow - aval = x(1, jj)**indx(1) * x(2, jj)**indx(2) - xx(jj, ii) = aval - END DO - END DO - -CASE (Heirarchical) - - ! xx = HeirarchicalBasis_Quadrangle( & - CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & - nrow=indx(1), ncol=indx(2)) - -CASE DEFAULT - - ! xx = TensorProdBasis_Quadrangle( & - CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x, & - basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & - nrow=indx(1), ncol=indx(2)) - -END SELECT - -! ans = MATMUL(xx, coeff0) -CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) - -END PROCEDURE LagrangeEvalAll_Quadrangle2_ - -!---------------------------------------------------------------------------- -! 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 - -! CALL Reallocate(ans, nsd + 1_I4B, np * nq) -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_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL LagrangeGradientEvalAll_Quadrangle1_(order=order, x=x, xij=xij, & - ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, coeff=coeff, & - firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) -END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, 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=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) 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 (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 (Heirarchical) - - ! 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_ - -!---------------------------------------------------------------------------- -! 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) - -isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) - -IF (isok) THEN - CALL VerticalEdgeBasisGradient_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, & - L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), qe1Orient=qe1Orient, qe2Orient=qe2Orient) - - dim2 = dim2 + indx(2) - -END IF - -! Edge basis function -isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) -IF (isok) THEN - CALL HorizontalEdgeBasisGradient_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, & - L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), pe3Orient=pe3Orient, pe4Orient=pe4Orient) - dim2 = dim2 + indx(2) -END IF - -! Cell basis function -isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) -IF (isok) THEN - CALL CellBasisGradient_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, dL1=dL1, & - dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), faceOrient=faceOrient) - - dim2 = dim2 + indx(2) -END IF - -DEALLOCATE (L1, L2, dL1, dL2) - -END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ - -!---------------------------------------------------------------------------- -! 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_ - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle3 -!---------------------------------------------------------------------------- - -END SUBMODULE Methods 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/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 new file mode 100644 index 000000000..72a513a69 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 @@ -0,0 +1,49 @@ +! 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) DOFMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetTotalDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Quadrangle +ans = (order + 1)**2 +END PROCEDURE GetTotalDOF_Quadrangle + +!---------------------------------------------------------------------------- +! GetTotalInDOF_Quadrangle +!---------------------------------------------------------------------------- + +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 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..499748c23 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 @@ -0,0 +1,758 @@ +! 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 + +!---------------------------------------------------------------------------- +! 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(:, :) + +maxQ = MAX(qe1, qe2) + +aint = SIZE(y) +nrow = SIZE(x) +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) + +CALL VerticalEdgeBasis_Quadrangle2_( & + qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=ncol, & + qe1Orient=orient, qe2Orient=orient) + +DEALLOCATE (L2, L1) + +END PROCEDURE VerticalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_( & + qe1, qe2, L1, L2, ans, nrow, ncol, qe1Orient, qe2Orient) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), qe1 + qe2 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + INTEGER(I4B), INTENT(IN), OPTIONAL :: qe1Orient, qe2Orient + !! orientation of left and right vertical edge + !! it can be 1 or -1 + + INTEGER(I4B) :: k2, cnt, ii + REAL(DFP) :: o1, o2 + + o1 = REAL(-qe1Orient, kind=DFP) + ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & + ! in master element + o2 = REAL(qe2Orient, kind=DFP) + + nrow = SIZE(L1, 1) + ncol = qe1 + qe2 - 2 + cnt = qe1 - 1 + + !! left vertical + DO CONCURRENT(k2=2:qe1, ii=1:nrow) + ans(ii, k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2) + END DO + + !! right vertical + DO CONCURRENT(k2=2:qe2, ii=1:nrow) + ans(ii, cnt + k2 - 1) = (o2**k2) * L1(ii, 1) * L2(ii, k2) + END DO + +END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! VerticalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_( & + qe1, qe2, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, qe1Orient, qe2Orient) + INTEGER(I4B), INTENT(IN) :: qe1 + !! order on left vertical edge (e1), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qe2 + !! order on right vertical edge(e2), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1=SIZE(L1, 1) + !! dim2=qe1 + qe2 - 2 + !! dim3= 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! range of data written to ans + INTEGER(I4B), INTENT(IN) :: qe1Orient, qe2Orient + !! orientation fo left and write vertical edge + !! it can be 1 or -1 + + INTEGER(I4B) :: k2, cnt, ii + REAL(DFP) :: o1, o2 + + o1 = REAL(-qe1Orient, kind=DFP) + ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & + ! in master element + o2 = REAL(qe2Orient, kind=DFP) + + dim1 = SIZE(L1, 1) + dim2 = qe1 + qe2 - 2 + dim3 = 2 + + cnt = qe1 - 1 + + DO CONCURRENT(k2=2:qe1, ii=1:dim1) + ans(ii, k2 - 1, 1) = (o1**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2) + ans(ii, k2 - 1, 2) = (o1**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2) + END DO + + DO CONCURRENT(k2=2:qe2, ii=1:dim1) + ans(ii, cnt + k2 - 1, 1) = (o2**(k2 - 1)) * dL1(ii, 1) * L2(ii, k2) + ans(ii, cnt + k2 - 1, 2) = (o2**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2) + END DO + +END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle +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) +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) + +CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & + ans=ans, nrow=nrow, ncol=ncol, pe3Orient=orient, pe4Orient=orient) + +DEALLOCATE (L1, L2) + +END PROCEDURE HorizontalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle2_( & + pe3, pe4, L1, L2, ans, nrow, ncol, pe3Orient, pe4Orient) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), pe3 + pe4 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient + !! orientaion of bottom and top edge + + INTEGER(I4B) :: k1, cnt, ii + REAL(DFP) :: o1, o2 + + o1 = REAL(pe3Orient, kind=DFP) + + o2 = REAL(-pe4Orient, kind=DFP) + ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & + ! in master element + + nrow = SIZE(L1, 1) + ncol = pe3 + pe4 - 2 + cnt = pe3 - 1 + + !! bottom edge + DO CONCURRENT(k1=2:pe3, ii=1:nrow) + ans(ii, k1 - 1) = (o1**k1) * L1(ii, k1) * L2(ii, 0) + END DO + + !! top edge + DO CONCURRENT(k1=2:pe4, ii=1:nrow) + ans(ii, cnt + k1 - 1) = (o2**k1) * L1(ii, k1) * L2(ii, 1) + END DO + +END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_( & + pe3, pe4, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, pe3Orient, pe4Orient) + INTEGER(I4B), INTENT(IN) :: pe3 + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: pe4 + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(L1, 1) + !! dim2 = pe3 + pe4 - 2 + !! dim3 = 2 + INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient + !! orientation of bottom and top horizontal edge + + !! internal variable + INTEGER(I4B) :: k1, cnt, ii + REAL(DFP) :: o1, o2 + + o1 = REAL(pe3Orient, kind=DFP) + + o2 = REAL(-pe4Orient, kind=DFP) + ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & + ! in master element + + dim1 = SIZE(L1, 1) + dim2 = pe3 + pe4 - 2 + dim3 = 2 + cnt = pe3 - 1 + + !! bottom edge + DO CONCURRENT(k1=2:pe3, ii=1:dim1) + ans(ii, k1 - 1, 1) = (o1**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0) + ans(ii, k1 - 1, 2) = (o1**(k1 - 1)) * L1(ii, k1) * dL2(ii, 0) + END DO + + !! top edge + DO CONCURRENT(k1=2:pe4, ii=1:dim1) + ans(ii, cnt + k1 - 1, 1) = (o2**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1) + ans(ii, cnt + k1 - 1, 2) = (o2**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1) + END DO + +END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle +INTEGER(I4B) :: nrow, ncol +CALL CellBasis_Quadrangle_(pb=pb, qb=qb, x=x, y=y, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE CellBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle_ +REAL(DFP) :: L1(1:SIZE(x), 0:pb) +REAL(DFP) :: L2(1:SIZE(y), 0:qb) +INTEGER(I4B), 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) + +END PROCEDURE CellBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & + faceOrient) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols written to ans + INTEGER(I4B), INTENT(IN) :: faceOrient(3) + !! face orientation + + !! Internal variables + INTEGER(I4B) :: k1, k2, ii, p, q + REAL(DFP) :: o1, o2 + + nrow = SIZE(L1, 1) + ncol = (pb - 1) * (qb - 1) + + o1 = REAL(faceOrient(1), kind=DFP) + o2 = REAL(faceOrient(2), kind=DFP) + + IF (faceOrient(3) .LT. 0_I4B) THEN + p = qb + q = pb + ELSE + p = pb + q = qb + END IF + + DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) + ans(ii, (q - 1) * (k1 - 2) + k2 - 1) = & + (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2) + END DO + +END SUBROUTINE CellBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! CellBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & + dL1, dL2, ans, dim1, dim2, dim3, faceOrient) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1=SIZE(L1, 1) + !! dim2=(pb - 1) * (qb - 1) + !! dim3=2 + INTEGER(I4B), INTENT(IN) :: faceOrient(3) + + !! internal variables + INTEGER(I4B) :: k1, k2, ii, p, q + REAL(DFP) :: o1, o2 + + dim1 = SIZE(L1, 1) + dim2 = (pb - 1) * (qb - 1) + dim3 = 2 + + o1 = REAL(faceOrient(1), kind=DFP) + o2 = REAL(faceOrient(2), kind=DFP) + + IF (faceOrient(3) .LT. 0_I4B) THEN + p = qb + q = pb + ELSE + p = pb + q = qb + END IF + + DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1) + + ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 1) = & + (o1**(k1 - 1)) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) + + ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 2) = & + (o1**k1) * (o2**(k2 - 1)) * L1(ii, k1) * dL2(ii, k2) + + END DO + +END SUBROUTINE CellBasisGradient_Quadrangle2_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & + qe1=qe1, qe2=qe2, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] +CALL HeirarchicalBasis_Quadrangle3_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, & + pe3Orient=orient, pe4Orient=orient, qe1Orient=orient, qe2Orient=orient, & + faceOrient=faceOrient, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle1_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Quadrangle1_( & + pb=p, pe3=p, pe4=p, qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle2_ +CALL HeirarchicalBasis_Quadrangle1_( & + pb=p, pe3=p, pe4=p, qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle3 +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(xij, 2) +ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL HeirarchicalBasis_Quadrangle3_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, & + pe3Orient=pe3Orient, pe4Orient=pe4Orient, qe1Orient=qe1Orient, & + qe2Orient=qe2Orient, faceOrient=faceOrient, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE HeirarchicalBasis_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_ +INTEGER(I4B) :: 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) + +! Edge basis function +isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) +IF (isok) THEN + CALL VerticalEdgeBasis_Quadrangle2_( & + qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans(:, ncol + 1:), nrow=indx(1), & + ncol=indx(2), qe1Orient=qe1Orient, qe2Orient=qe2Orient) + + ncol = ncol + indx(2) +END IF + +! Edge basis function +isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) +IF (isok) THEN + CALL HorizontalEdgeBasis_Quadrangle2_( & + pe3=pe3, pe4=pe4, L1=L1, L2=L2, ans=ans(:, ncol + 1:), nrow=indx(1), & + ncol=indx(2), pe3Orient=pe3Orient, pe4Orient=pe4Orient) + ncol = ncol + indx(2) +END IF + +! Cell basis function +isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) +IF (isok) THEN + CALL CellBasis_Quadrangle2_( & + pb=pb, qb=qb, L1=L1, L2=L2, ans=ans(:, ncol + 1:), nrow=indx(1), & + ncol=indx(2), faceOrient=faceOrient) + ncol = ncol + indx(2) +END IF + +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) + +isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) + +IF (isok) THEN + CALL VerticalEdgeBasisGradient_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, & + L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & + dim2=indx(2), dim3=indx(3), qe1Orient=qe1Orient, qe2Orient=qe2Orient) + + dim2 = dim2 + indx(2) + +END IF + +! Edge basis function +isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) +IF (isok) THEN + CALL HorizontalEdgeBasisGradient_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, & + L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & + dim2=indx(2), dim3=indx(3), pe3Orient=pe3Orient, pe4Orient=pe4Orient) + dim2 = dim2 + indx(2) +END IF + +! Cell basis function +isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) +IF (isok) THEN + CALL CellBasisGradient_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, dL1=dL1, & + dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & + dim2=indx(2), dim3=indx(3), faceOrient=faceOrient) + + dim2 = dim2 + indx(2) +END IF + +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..82623b7aa --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 @@ -0,0 +1,568 @@ +! 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 +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_ + +!---------------------------------------------------------------------------- +! 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) :: firstCall0, isCoeff +INTEGER(I4B) :: ii, jj, basisType0, indx(2), degree(SIZE(xij, 2), 2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) ,xx(SIZE(x, 2), SIZE(xij, 2)), & + aval + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) + +basisType0 = INPUT(default=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:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) + +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 (ncol .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Quadrangle1", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN + END IF +#endif + + DO ii = 1, ncol + indx(1:2) = degree(ii, 1:2) + DO jj = 1, nrow + aval = x(1, jj)**indx(1) * x(2, jj)**indx(2) + xx(jj, ii) = aval + END DO + END DO + +CASE (TypePolynomialOpt%Hierarchical) + ! xx = HeirarchicalBasis_Quadrangle( & + CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & + nrow=indx(1), ncol=indx(2)) + +CASE DEFAULT + + ! xx = TensorProdBasis_Quadrangle( & + CALL TensorProdBasis_Quadrangle_( & + p=order, q=order, xij=x, basisType1=basisType0, basisType2=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, ans=xx, nrow=indx(1), ncol=indx(2)) + +END SELECT + +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) + +END PROCEDURE LagrangeEvalAll_Quadrangle2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 new file mode 100644 index 000000000..11cc697b5 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 @@ -0,0 +1,44 @@ +! 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 +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! RefElemDomain_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE RefElemDomain_Quadrangle +ans = "BIUNIT" +END PROCEDURE RefElemDomain_Quadrangle + +!---------------------------------------------------------------------------- +! FacetConnectivity +!---------------------------------------------------------------------------- + +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 +!---------------------------------------------------------------------------- + +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 91% rename from src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 rename to src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90 index b4391170b..a530d0826 100644 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ b/src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90 @@ -20,9 +20,7 @@ ! summary: This submodule contains method for [[ReferenceQuadrangle_]] SUBMODULE(ReferenceQuadrangle_Method) Methods - -USE GlobalData, ONLY: Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, & - Quadrangle16, Point, Line2, Equidistance, INT8 +USE GlobalData, ONLY: INT8 USE ReferenceElement_Method, ONLY: ReferenceTopology, DEALLOCATE, & ReferenceElement_Initiate => Initiate @@ -40,7 +38,7 @@ USE ApproxUtility, ONLY: OPERATOR(.approxeq.) -USE AppendUtility +USE AppendUtility, ONLY: OPERATOR(.append.) USE StringUtility, ONLY: UpperCase @@ -56,6 +54,8 @@ USE MiscUtility, ONLY: Int2Str +USE BaseType, ONLY: TypeElemNameOpt, TypeInterpolationOpt + IMPLICIT NONE CONTAINS @@ -65,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 @@ -117,13 +117,13 @@ MODULE PROCEDURE TotalNodesInElement_Quadrangle SELECT CASE (elemType) -CASE (Quadrangle4) +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 @@ -136,13 +136,13 @@ MODULE PROCEDURE ElementOrder_Quadrangle SELECT CASE (elemType) -CASE (Quadrangle4) +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 @@ -154,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 @@ -201,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( & @@ -232,9 +232,10 @@ 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] @@ -242,7 +243,7 @@ DO jj = 1, order + 1 ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), & - name=Point) + name=TypeElemNameOpt%Point) END DO ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), & @@ -261,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 @@ -308,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 @@ -365,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)) @@ -664,8 +665,10 @@ END SUBROUTINE PARALLELOGRAMAREA2D !---------------------------------------------------------------------------- MODULE PROCEDURE GetFaceElemType_Quadrangle1 -INTEGER(I4B) :: order -order = ElementOrder_Quadrangle(Input(default=Quadrangle, option=elemType)) +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_Quadrangle1 From 8b72edf23a3e0504e9f401a7f7792f1c8579614a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 12:52:53 +0900 Subject: [PATCH 075/184] Adding Triangle Moving triangle related utility to a new directory. --- src/modules/CMakeLists.txt | 3 + src/modules/Geometry/CMakeLists.txt | 2 - src/modules/Geometry/src/Line_Method.F90 | 176 ++++---- src/modules/Geometry/src/Plane_Method.F90 | 26 +- src/modules/Polynomial/CMakeLists.txt | 2 +- src/modules/Random/src/Random_Method.F90 | 28 +- src/modules/Triangle/CMakeLists.txt | 23 ++ .../src/ReferenceTriangle_Method.F90 | 0 .../src/TriangleInterpolationUtility.F90 | 0 .../src/Triangle_Method.F90 | 2 +- src/modules/Utility/src/MiscUtility.F90 | 23 +- src/submodules/CMakeLists.txt | 3 + src/submodules/Geometry/CMakeLists.txt | 4 +- src/submodules/Polynomial/CMakeLists.txt | 6 - .../TriangleInterpolationUtility@Methods.F90 | 376 ------------------ src/submodules/Triangle/CMakeLists.txt | 28 ++ .../src/ReferenceTriangle_Method@Methods.F90 | 8 +- ...lationUtility@HeirarchicalBasisMethods.F90 | 0 ...erpolationUtility@LagrangeBasisMethods.F90 | 0 .../TriangleInterpolationUtility@Methods.F90 | 0 ...polationUtility@OrthogonalBasisMethods.F90 | 0 ...InterpolationUtility@QuadratureMethods.F90 | 2 +- .../src/Triangle_Method@Methods.F90 | 240 ++++++++++- ...angle_QuadraturePoint_InternalUseOnly.F90} | 6 +- .../src/Triangle_QuadraturePoint_Solin.F90} | 7 +- 25 files changed, 437 insertions(+), 528 deletions(-) create mode 100644 src/modules/Triangle/CMakeLists.txt rename src/modules/{Geometry => Triangle}/src/ReferenceTriangle_Method.F90 (100%) rename src/modules/{Polynomial => Triangle}/src/TriangleInterpolationUtility.F90 (100%) rename src/modules/{Geometry => Triangle}/src/Triangle_Method.F90 (99%) delete mode 100644 src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 create mode 100644 src/submodules/Triangle/CMakeLists.txt rename src/submodules/{Geometry => Triangle}/src/ReferenceTriangle_Method@Methods.F90 (99%) rename src/submodules/{Polynomial => Triangle}/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 (100%) rename src/submodules/{Polynomial => Triangle}/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 (100%) rename src/submodules/{Polynomial => Triangle}/src/TriangleInterpolationUtility@Methods.F90 (100%) rename src/submodules/{Polynomial => Triangle}/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 (100%) rename src/submodules/{Polynomial => Triangle}/src/TriangleInterpolationUtility@QuadratureMethods.F90 (99%) rename src/submodules/{Geometry => Triangle}/src/Triangle_Method@Methods.F90 (86%) rename src/submodules/{Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 => Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90} (99%) rename src/submodules/{Polynomial/src/QuadraturePoint_Triangle_Solin.F90 => Triangle/src/Triangle_QuadraturePoint_Solin.F90} (99%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index c30b224d0..436ffcd4b 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -95,6 +95,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt) # BaseContinuity include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt) +# Triangle +include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt) + # Quadrangle include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 8b6e08102..b86d701e7 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -22,9 +22,7 @@ target_sources( ${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}/ReferenceTetrahedron_Method.F90 ${src_path}/ReferenceHexahedron_Method.F90 ${src_path}/ReferencePrism_Method.F90 diff --git a/src/modules/Geometry/src/Line_Method.F90 b/src/modules/Geometry/src/Line_Method.F90 index 2c1757412..3eeb8ed22 100644 --- a/src/modules/Geometry/src/Line_Method.F90 +++ b/src/modules/Geometry/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/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/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 2ca278d11..3e45be5c3 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -29,7 +29,7 @@ target_sources( ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 ${src_path}/LineInterpolationUtility.F90 - ${src_path}/TriangleInterpolationUtility.F90 + # ${src_path}/TriangleInterpolationUtility.F90 ${src_path}/TetrahedronInterpolationUtility.F90 ${src_path}/HexahedronInterpolationUtility.F90 ${src_path}/PrismInterpolationUtility.F90 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/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 100% rename from src/modules/Geometry/src/ReferenceTriangle_Method.F90 rename to src/modules/Triangle/src/ReferenceTriangle_Method.F90 diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/TriangleInterpolationUtility.F90 rename to src/modules/Triangle/src/TriangleInterpolationUtility.F90 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/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/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index 2f7126a86..fb991455c 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -27,6 +27,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) # Utility include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) +# Triangle +include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt) + # Quadrangle include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index 0d5c9d2cf..da8f7169f 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -29,8 +29,8 @@ target_sources( ${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}/ReferenceTriangle_Method@Methods.F90 + # ${src_path}/Triangle_Method@Methods.F90 ${src_path}/Plane_Method@Methods.F90 ${src_path}/ReferenceTetrahedron_Method@Methods.F90 ${src_path}/ReferenceHexahedron_Method@Methods.F90 diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index c200641b1..9204b01c7 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -19,13 +19,7 @@ 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}/TetrahedronInterpolationUtility@Methods.F90 ${src_path}/HexahedronInterpolationUtility@Methods.F90 ${src_path}/PrismInterpolationUtility@Methods.F90 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/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 99% rename from src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 rename to src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90 index 49d90b68f..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 diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 similarity index 100% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 similarity index 100% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 similarity index 100% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 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/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 similarity index 99% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 0badc8787..4e28ef681 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -16,7 +16,7 @@ SUBMODULE(TriangleInterpolationUtility) QuadratureMethods USE BaseMethod -USE QuadraturePoint_Triangle_Solin, ONLY: QuadraturePointTriangleSolin, & +USE Triangle_QuadraturePoint_Solin, ONLY: QuadraturePointTriangleSolin, & QuadraturePointTriangleSolin_, & QuadratureNumberTriangleSolin IMPLICIT NONE 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 From 1359e0fbad5f6223770ab832a7dcd28f6d3561d8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 13:07:51 +0900 Subject: [PATCH 076/184] Adding line --- src/modules/CMakeLists.txt | 3 + src/modules/Geometry/CMakeLists.txt | 2 - src/modules/Line/CMakeLists.txt | 23 + .../src/LineInterpolationUtility.F90 | 0 src/modules/Line/src/Line_Method.F90 | 443 ++++++++++++++ src/modules/Line/src/ReferenceLine_Method.F90 | 549 +++++++++++++++++ src/modules/Polynomial/CMakeLists.txt | 2 - src/submodules/CMakeLists.txt | 3 + src/submodules/Geometry/CMakeLists.txt | 4 - .../Geometry/src/Line_Method@Methods.F90 | 339 ----------- src/submodules/Line/CMakeLists.txt | 23 + .../src/LineInterpolationUtility@Methods.F90 | 0 .../Line/src/Line_Method@Methods.F90 | 556 ++++++++++++++++++ .../src/ReferenceLine_Method@Methods.F90 | 0 src/submodules/Polynomial/CMakeLists.txt | 3 +- 15 files changed, 1601 insertions(+), 349 deletions(-) create mode 100644 src/modules/Line/CMakeLists.txt rename src/modules/{Polynomial => Line}/src/LineInterpolationUtility.F90 (100%) create mode 100644 src/modules/Line/src/Line_Method.F90 create mode 100644 src/modules/Line/src/ReferenceLine_Method.F90 delete mode 100644 src/submodules/Geometry/src/Line_Method@Methods.F90 create mode 100644 src/submodules/Line/CMakeLists.txt rename src/submodules/{Polynomial => Line}/src/LineInterpolationUtility@Methods.F90 (100%) create mode 100644 src/submodules/Line/src/Line_Method@Methods.F90 rename src/submodules/{Geometry => Line}/src/ReferenceLine_Method@Methods.F90 (100%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 436ffcd4b..3ab324782 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -95,6 +95,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt) # BaseContinuity include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt) +# Line +include(${CMAKE_CURRENT_LIST_DIR}/Line/CMakeLists.txt) + # Triangle include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index b86d701e7..576de90a5 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -20,8 +20,6 @@ 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}/Plane_Method.F90 ${src_path}/ReferenceTetrahedron_Method.F90 ${src_path}/ReferenceHexahedron_Method.F90 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/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/LineInterpolationUtility.F90 rename to src/modules/Line/src/LineInterpolationUtility.F90 diff --git a/src/modules/Line/src/Line_Method.F90 b/src/modules/Line/src/Line_Method.F90 new file mode 100644 index 000000000..3eeb8ed22 --- /dev/null +++ b/src/modules/Line/src/Line_Method.F90 @@ -0,0 +1,443 @@ +! 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 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: finds if an explicit line is degenerate in ND. +! +!# Introduction +! +! The explicit form of a line in ND is: +! +! the line through the points P1 and P2. +! +! An explicit line is degenerate if the two defining points are equal. +! +!# Parameters: +! +! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. +! +! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), two points on the +! line. +! +! Output, logical ( kind = 4 ) LINE_EXP_IS_DEGENERATE_ND, is TRUE if the +! line is degenerate. +! + +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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: converts an explicit line to implicit form in 2D. +! +!# Introduction +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: finds if an implicit point is degenerate in 2D. +! +!# Introduction +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Parameters: +! +! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. +! +! Output, logical ( kind = 4 ) LINE_IMP_IS_DEGENERATE_2D, is true if the +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: determines where two implicit lines intersect in 2D. +! +!# Introduction +! +! The implicit form of a line in 2D is: +! +! A * X + B * Y + C = 0 +! +! Parameters: +! +! Input, real ( kind = 8 ) A1, B1, C1, define the first line. +! At least one of A1 and B1 must be nonzero. +! +! Input, real ( kind = 8 ) A2, B2, C2, define the second line. +! At least one of A2 and B2 must be nonzero. +! +! Output, integer ( kind = 4 ) IVAL, reports on the intersection. +! +! -1, both A1 and B1 were zero. +! -2, both A2 and B2 were zero. +! 0, no intersection, the lines are parallel. +! 1, one intersection point, returned in P. +! 2, infinitely many intersections, the lines are identical. +! +! Output, real ( kind = 8 ) P(2), if IVAL = 1, then P is +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: computes a line perpendicular to a line and through a point. +! +!# Introduction +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The input point P3 should NOT lie on the line (P1,P2). If it +! does, then the output value P4 will equal P3. +! +! P1-----P4-----------P2 +! | +! | +! P3 +! +! P4 is also the nearest point on the line (P1,P2) to the point P3. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! Input, real ( kind = 8 ) P3(2), a point (presumably not on the +! line (P1,P2)), through which the perpendicular must pass. +! +! Output, real ( kind = 8 ) P4(2), a point on the line (P1,P2), +! such that the line (P3,P4) is perpendicular to the line (P1,P2). +! +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: determines where two explicit lines intersect in 2D. +! +!# Introduction +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the first line. +! +! Input, real ( kind = 8 ) Q1(2), Q2(2), two points on the second line. +! +! Output, integer ( kind = 4 ) IVAL, reports on the intersection: +! 0, no intersection, the lines may be parallel or degenerate. +! 1, one intersection point, returned in P. +! 2, infinitely many intersections, the lines are identical. +! +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: distance ( line segment, point ) in 2D. +! +!# Introduction +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! The nearest point will satisfy the condition +! +! PN = (1-T) * P1 + T * P2. +! +! T will always be between 0 and 1. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. +! +! Input, real ( kind = 8 ) P(2), +! the point whose nearest neighbor on the line +! segment is to be determined. +! +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: distance ( line segment, point ) in 3D. +! +!# Introduction +! +! Discussion: +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! The nearest point will satisfy the condition +! +! PN = (1-T) * P1 + T * P2. +! +! T will always be between 0 and 1. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the segment. +! +! Input, real ( kind = 8 ) P(3), the point whose nearest neighbor on +! the line segment is to be determined. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: signed distance ( exp line, point ) in 2D. +! +!# Introduction +! +! Discussion: +! +! The explicit form of a line in 2D is: +! +! the line through the points P1 and P2. +! +! The signed distance has two interesting properties: +! +! * The absolute value of the signed distance is the +! usual (Euclidean) distance. +! +! * Points with signed distance 0 lie on the line, +! points with a negative signed distance lie on one side +! of the line, +! points with a positive signed distance lie on the +! other side of the line. +! +! Assuming that C is nonnegative, then if a point is a positive +! distance away from the line, it is on the same side of the +! line as the point (0,0), and if it is a negative distance +! from the line, it is on the opposite side from (0,0). +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. +! +! Input, real ( kind = 8 ) P(2), the point whose signed distance is +! desired. +! +! 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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 29 Aug 2022 +! summary: nearest point on line segment to point in 2D. +! +!# Introduction +! +! +! A line segment is the finite portion of a line that lies between +! two points P1 and P2. +! +! The nearest point will satisfy the condition +! +! PN = (1-T) * P1 + T * P2. +! +! T will always be between 0 and 1. +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. +! +! Input, real ( kind = 8 ) P(2), the point whose nearest neighbor +! on the line segment is to be determined. +! +! Output, real ( kind = 8 ) PN(2), the point on the line segment which is +! nearest the point P. +! +! Output, real ( kind = 8 ) DIST, the distance from the point to the +! nearest point on the line segment. +! +! Output, real ( kind = 8 ) T, the relative position of the point PN +! 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 + +END MODULE Line_Method diff --git a/src/modules/Line/src/ReferenceLine_Method.F90 b/src/modules/Line/src/ReferenceLine_Method.F90 new file mode 100644 index 000000000..8c39b8877 --- /dev/null +++ b/src/modules/Line/src/ReferenceLine_Method.F90 @@ -0,0 +1,549 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 5 March 2021 +! summary: This submodule contains method for [[ReferenceLine_]] + +MODULE ReferenceLine_Method +USE BaseType, ONLY: ReferenceTopology_, & + ReferenceElement_, & + ReferenceLine_ + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Initiate +PUBLIC :: ReferenceLine +PUBLIC :: ReferenceLine_Pointer +PUBLIC :: HighOrderElement_Line +PUBLIC :: Measure_Simplex_Line +PUBLIC :: Line_Quality +PUBLIC :: Quality_Line +PUBLIC :: LineName +PUBLIC :: RefLineCoord +PUBLIC :: RefCoord_Line +PUBLIC :: DEFAULT_Ref_LINE_COORD +PUBLIC :: FacetElements_Line +PUBLIC :: ElementType_Line +PUBLIC :: ElementOrder_Line +PUBLIC :: TotalNodesInElement_Line +PUBLIC :: TotalEntities_Line +PUBLIC :: FacetTopology_Line +PUBLIC :: ElementName_Line +PUBLIC :: MaxOrder_Line +PUBLIC :: GetFaceElemType_Line +PUBLIC :: GetEdgeConnectivity_Line +PUBLIC :: GetFaceConnectivity_Line + +#ifdef MAX_LINE_ORDER +INTEGER(I4B), PARAMETER :: MaxOrder_Line = MAX_LINE_ORDER +#else +INTEGER(I4B), PARAMETER :: MaxOrder_Line = 5_I4B +#endif + +#ifdef REF_LINE_IS_UNIT +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]) +#endif + +!---------------------------------------------------------------------------- +! ElementName +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-25 +! summary: Returns element name in character from element number/type + +INTERFACE + MODULE PURE FUNCTION ElementName_Line(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + CHARACTER(:), ALLOCATABLE :: ans + END FUNCTION ElementName_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetTopology_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns the facet topology of the given element type + +INTERFACE + MODULE PURE SUBROUTINE FacetTopology_Line(elemType, nptrs, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nptrs(:) + TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetTopology_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalEntities_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total entities + +INTERFACE + MODULE PURE FUNCTION TotalEntities_Line(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans(4) + END FUNCTION TotalEntities_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! TotalNodesInElement_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns total nodes in element + +INTERFACE + MODULE PURE FUNCTION TotalNodesInElement_Line(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION TotalNodesInElement_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementOrder_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns order of element + +INTERFACE + MODULE PURE FUNCTION ElementOrder_Line(elemType) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B) :: ans + END FUNCTION ElementOrder_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! ElementType_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-22 +! summary: Returns ElementType for line from char + +INTERFACE + MODULE PURE FUNCTION ElementType_Line(elemName) RESULT(ans) + CHARACTER(*), INTENT(IN) :: elemName + INTEGER(I4B) :: ans + END FUNCTION ElementType_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! FacetElements_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Line + MODULE SUBROUTINE FacetElements_Line1(refelem, ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Line1 +END INTERFACE FacetElements_Line + +!---------------------------------------------------------------------------- +! FacetElements_Line +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-21 +! summary: Get FacetElements + +INTERFACE FacetElements_Line + MODULE SUBROUTINE FacetElements_Line2(elemType, nsd, ans) + INTEGER(I4B), INTENT(IN) :: elemType + INTEGER(I4B), INTENT(IN) :: nsd + TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) + END SUBROUTINE FacetElements_Line2 +END INTERFACE FacetElements_Line + +!---------------------------------------------------------------------------- +! LineName +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-17 +! summary: Returns the integer name of reference line for given order + +INTERFACE LineName + MODULE PURE FUNCTION LineName1(order) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + INTEGER(I4B) :: ans + END FUNCTION LineName1 +END INTERFACE LineName + +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This subroutine constructs an instance of line reference element +! +!# Introduction +! This routine constructs an instance of [[ReferenceLine_]] +! element of order equal to 1. +! +! - `xij` denotes the nodal coordinate, if it is not present than RESHAPE( +! [-1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 2] ) is used. +! +!@note +! Note that SIZE(xij,1) should be equal to 3, i.e., x,y,z coord. Also note +! that this routine creats a linear element. +!@endnote +! +!### Usage +! +!```fortran +! type( ReferenceLine_ ) :: obj1 +! real( dfp ) :: xij( 3, 2 ) +! call random_number( xij ) +! call initiate( obj=obj1, nsd=3, xij ) +! call display( obj1, "obj1 : " ) +!``` + +INTERFACE Initiate + MODULE PURE SUBROUTINE Initiate_Ref_Line(obj, nsd, xij, domainName) + CLASS(ReferenceLine_), INTENT(INOUT) :: obj + !! The instance + INTEGER(I4B), INTENT(IN) :: nsd + !! Spatial dimension of the problem + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + !! Coords of element + CHARACTER(*), INTENT(IN), OPTIONAL :: domainName + !! Domain name + !! UNIT + !! BIUNIT + !! GENERAL + END SUBROUTINE Initiate_Ref_Line +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! ReferenceLine@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This routine constructs an instance of line reference element +! +!# Introduction +! This routine constructs an instance of [[ReferenceLine_]] element of order +! equal to 1. +! +! - `xij` denotes the nodal coordinate, if it is not present than RESHAPE( +! [-1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 2] ) is used. +! +!@note +! Note that SIZE(xij,1) should be equal to 3, i.e., x,y,z coord. Also note +! that this routine creats a linear element. +!@endnote +! +!### Usage +! +!```fortran +! type( ReferenceLine_ ) :: obj +! obj = ReferenceLine(nsd=3) +! call display( obj, 'obj : ' ) +!``` + +INTERFACE ReferenceLine + MODULE PURE FUNCTION Reference_Line(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + TYPE(ReferenceLine_) :: obj + CHARACTER(*), INTENT(IN), OPTIONAL :: domainName + !! Domain name + !! UNIT + !! BIUNIT + !! GENERAL + END FUNCTION Reference_Line +END INTERFACE ReferenceLine + +!---------------------------------------------------------------------------- +! ReferenceLine_Pointer@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This routine constructs an instance of line reference element +! +!# Introduction +! This routine constructs an instance of [[ReferenceLine_]] element of order +! equal to 1. +! +! - `xij` denotes the nodal coordinate, if it is not present than RESHAPE( +! [-1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 2] ) is used. +! +!@note +! Note that SIZE(xij,1) should be equal to 3, i.e., x,y,z coord. Also note +! that this routine creats a linear element. +!@endnote +! +!### Usage +! +!```fortran +! class( ReferenceElement_ ), Pointer :: obj => NULL() +! obj => ReferenceLine_Pointer( nsd = 3 ) +! call display( obj, "obj : ") +!``` + +INTERFACE ReferenceLine_Pointer + MODULE FUNCTION Reference_Line_Pointer_1(nsd, xij, domainName) RESULT(obj) + INTEGER(I4B), INTENT(IN) :: nsd + REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) + CLASS(ReferenceLine_), POINTER :: obj + CHARACTER(*), INTENT(IN), OPTIONAL :: domainName + !! Domain name + !! UNIT + !! BIUNIT + !! GENERAL + END FUNCTION Reference_Line_Pointer_1 +END INTERFACE ReferenceLine_Pointer + +!---------------------------------------------------------------------------- +! LagrangeElement@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 March 2021 +! summary: This function returns lagrange element on line +! +!# Introduction +! Returns lagrange line element of Higher order. By lagrange element we means +! standard finite elements, with equi-distance lagrange interpolation points. +! +!### Usage +! +!```fortran +! type( ReferenceLine_ ) :: obj1, obj3 +! real( dfp ) :: xij( 3, 2 ) +! call random_number( xij ) +! call initiate( obj=obj1, nsd=3, xij=xij ) +! call display( obj1, "obj1 : " ) +! call obj1%HighOrderElement( order=2, HighOrderobj=obj3 ) <--- +! call display( obj3, "Second order Lagrange Element : ") +!``` + +INTERFACE + MODULE SUBROUTINE HighOrderElement_Line(refelem, order, obj, ipType) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + !! Linear line element + INTEGER(I4B), INTENT(IN) :: order + !! order or generated element + CLASS(ReferenceElement_), INTENT(INOUT) :: obj + !! High order lagrange line element + INTEGER(I4B), INTENT(IN) :: ipType + END SUBROUTINE HighOrderElement_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! MeasureSimplex@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 March 2021 +! summary: This function returns the measure of linear line element +! +!# Introduction +! +! This function returns the measure of linear line element. Its generic form +! is given by [[ReferenceElement_Method:MeasureSimplex]] +! +! +!### Usage +! +!```fortran +! type( ReferenceLine_ ) :: obj +! real( dfp ) :: xij( 3, 2 ) +! call random_number( xij ) +! call initiate( obj=obj, nsd=3, xij=xij ) +! call display( MeasureSimplex(obj, obj%xij), "Measure :: ") +!``` + +INTERFACE + MODULE PURE FUNCTION Measure_Simplex_Line(refelem, xij) RESULT(Ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + REAL(DFP) :: Ans + END FUNCTION Measure_Simplex_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! line_quality@Methods +!---------------------------------------------------------------------------- + +INTERFACE Quality_Line + MODULE FUNCTION Line_Quality(refelem, xij, measure) RESULT(Ans) + CLASS(ReferenceElement_), INTENT(IN) :: refelem + REAL(DFP), INTENT(IN) :: xij(:, :) + INTEGER(I4B), INTENT(IN) :: measure + REAL(DFP) :: Ans + END FUNCTION Line_Quality +END INTERFACE Quality_Line + +!---------------------------------------------------------------------------- +! RefLineCoord +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference triangle + +INTERFACE RefCoord_Line + MODULE PURE FUNCTION RefLineCoord(refLine) RESULT(ans) + CHARACTER(*), INTENT(IN) :: refLine + !! "unit" + !! "biunit" + REAL(DFP) :: ans(1, 2) + END FUNCTION RefLineCoord +END INTERFACE RefCoord_Line + +!---------------------------------------------------------------------------- +! GetEdgeConnectivity +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Get the face connectivity of Line +! +!# Introduction +! +! This routine calls [[GetEdgeConnectivity_Line]] with opt=2 + +INTERFACE + MODULE PURE SUBROUTINE GetFaceConnectivity_Line(con, opt, order, nrow, ncol) + INTEGER(I4B), INTENT(INOUT) :: con(:, :) + !! Connectivity + !! The columns represents the Face number + !! The row represents a Face + !! con should be allocated by the user + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! This option is ignored now + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! order of element + !! Currently any order is valid + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow + !! Number of rows written in con + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol + !! Numbers of cols written in con + END SUBROUTINE GetFaceConnectivity_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! GetEdgeElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns the element type of each face + +INTERFACE + MODULE PURE SUBROUTINE GetEdgeConnectivity_Line(con, opt, order, nrow, ncol) + INTEGER(I4B), INTENT(INOUT) :: con(:, :) + !! Connectivity + !! The columns represents the edge number + !! The row represents a edge + !! con should be allocated by the user + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! [1,2], [1,3], [2,3]. This is DEFAULT + !! If opt =2, then edge connectivity for Lagrangian approximation + !! [1,2], [2,3], [3,1] + INTEGER(I4B), OPTIONAL, INTENT(IN) :: order + !! order of element + !! Currently order is used only when opt=2 + !! Currently any order is valid + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow + !! Number of rows written in con + INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol + !! Numbers of cols written in con + END SUBROUTINE GetEdgeConnectivity_Line +END INTERFACE + +!---------------------------------------------------------------------------- +! 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_Line1(elemType, faceElemType, opt, & + tFaceNodes) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) + !! Element names of faces + INTEGER(I4B), OPTIONAL, 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_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 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ReferenceLine_Method diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 3e45be5c3..e1bf3d195 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -28,8 +28,6 @@ target_sources( ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/LineInterpolationUtility.F90 - # ${src_path}/TriangleInterpolationUtility.F90 ${src_path}/TetrahedronInterpolationUtility.F90 ${src_path}/HexahedronInterpolationUtility.F90 ${src_path}/PrismInterpolationUtility.F90 diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index fb991455c..e25a3c572 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -27,6 +27,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) # Utility include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) +# Line +include(${CMAKE_CURRENT_LIST_DIR}/Line/CMakeLists.txt) + # Triangle include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index da8f7169f..fb45f808a 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -27,10 +27,6 @@ target_sources( ${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}/ReferenceTetrahedron_Method@Methods.F90 ${src_path}/ReferenceHexahedron_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/Line/CMakeLists.txt b/src/submodules/Line/CMakeLists.txt new file mode 100644 index 000000000..f4b7e38ed --- /dev/null +++ b/src/submodules/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@Methods.F90 + ${src_path}/ReferenceLine_Method@Methods.F90 + ${src_path}/LineInterpolationUtility@Methods.F90) diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 similarity index 100% rename from src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 rename to src/submodules/Line/src/LineInterpolationUtility@Methods.F90 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 100% rename from src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 rename to src/submodules/Line/src/ReferenceLine_Method@Methods.F90 diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 9204b01c7..1fb054f21 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -18,8 +18,7 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/LineInterpolationUtility@Methods.F90 - ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90 + PRIVATE ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90 ${src_path}/TetrahedronInterpolationUtility@Methods.F90 ${src_path}/HexahedronInterpolationUtility@Methods.F90 ${src_path}/PrismInterpolationUtility@Methods.F90 From 4bfb0210843696c6740f395ca9f59f3df53fbd4e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 13:23:50 +0900 Subject: [PATCH 077/184] Adding Tetrahedron --- src/modules/CMakeLists.txt | 3 + src/modules/Geometry/CMakeLists.txt | 1 - src/modules/Geometry/src/Line_Method.F90 | 443 -------------- .../Geometry/src/ReferenceLine_Method.F90 | 549 ------------------ src/modules/Polynomial/CMakeLists.txt | 1 - src/modules/Tetrahedron/CMakeLists.txt | 21 + .../src/ReferenceTetrahedron_Method.F90 | 0 .../src/TetrahedronInterpolationUtility.F90 | 0 src/submodules/CMakeLists.txt | 3 + src/submodules/Geometry/CMakeLists.txt | 1 - src/submodules/Polynomial/CMakeLists.txt | 4 +- src/submodules/Tetrahedron/CMakeLists.txt | 23 + .../ReferenceTetrahedron_Method@Methods.F90 | 0 ...etrahedronInterpolationUtility@Methods.F90 | 2 +- .../Tetrahedron_QuadraturePoint_Solin.F90} | 4 +- .../src/include/Tetrahedron/order1.F90 | 0 .../src/include/Tetrahedron/order10.F90 | 0 .../src/include/Tetrahedron/order11.F90 | 0 .../src/include/Tetrahedron/order12.F90 | 0 .../src/include/Tetrahedron/order13.F90 | 0 .../src/include/Tetrahedron/order14.F90 | 0 .../src/include/Tetrahedron/order15.F90 | 0 .../src/include/Tetrahedron/order16.F90 | 0 .../src/include/Tetrahedron/order17.F90 | 0 .../src/include/Tetrahedron/order18.F90 | 0 .../src/include/Tetrahedron/order19.F90 | 0 .../src/include/Tetrahedron/order2.F90 | 0 .../src/include/Tetrahedron/order20.F90 | 0 .../src/include/Tetrahedron/order21.F90 | 0 .../src/include/Tetrahedron/order3.F90 | 0 .../src/include/Tetrahedron/order4.F90 | 0 .../src/include/Tetrahedron/order5.F90 | 0 .../src/include/Tetrahedron/order6.F90 | 0 .../src/include/Tetrahedron/order7.F90 | 0 .../src/include/Tetrahedron/order8.F90 | 0 .../src/include/Tetrahedron/order9.F90 | 0 36 files changed, 54 insertions(+), 1001 deletions(-) delete mode 100644 src/modules/Geometry/src/Line_Method.F90 delete mode 100644 src/modules/Geometry/src/ReferenceLine_Method.F90 create mode 100644 src/modules/Tetrahedron/CMakeLists.txt rename src/modules/{Geometry => Tetrahedron}/src/ReferenceTetrahedron_Method.F90 (100%) rename src/modules/{Polynomial => Tetrahedron}/src/TetrahedronInterpolationUtility.F90 (100%) create mode 100644 src/submodules/Tetrahedron/CMakeLists.txt rename src/submodules/{Geometry => Tetrahedron}/src/ReferenceTetrahedron_Method@Methods.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/TetrahedronInterpolationUtility@Methods.F90 (99%) rename src/submodules/{Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 => Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90} (98%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order1.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order10.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order11.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order12.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order13.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order14.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order15.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order16.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order17.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order18.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order19.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order2.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order20.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order21.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order3.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order4.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order5.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order6.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order7.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order8.F90 (100%) rename src/submodules/{Polynomial => Tetrahedron}/src/include/Tetrahedron/order9.F90 (100%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 3ab324782..b0c63d20f 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -104,6 +104,9 @@ 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) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 576de90a5..31367b253 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -21,7 +21,6 @@ target_sources( PRIVATE ${src_path}/ReferenceElement_Method.F90 ${src_path}/ReferencePoint_Method.F90 ${src_path}/Plane_Method.F90 - ${src_path}/ReferenceTetrahedron_Method.F90 ${src_path}/ReferenceHexahedron_Method.F90 ${src_path}/ReferencePrism_Method.F90 ${src_path}/ReferencePyramid_Method.F90 diff --git a/src/modules/Geometry/src/Line_Method.F90 b/src/modules/Geometry/src/Line_Method.F90 deleted file mode 100644 index 3eeb8ed22..000000000 --- a/src/modules/Geometry/src/Line_Method.F90 +++ /dev/null @@ -1,443 +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 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: finds if an explicit line is degenerate in ND. -! -!# Introduction -! -! The explicit form of a line in ND is: -! -! the line through the points P1 and P2. -! -! An explicit line is degenerate if the two defining points are equal. -! -!# Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. -! -! Input, real ( kind = 8 ) P1(DIM_NUM), P2(DIM_NUM), two points on the -! line. -! -! Output, logical ( kind = 4 ) LINE_EXP_IS_DEGENERATE_ND, is TRUE if the -! line is degenerate. -! - -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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: converts an explicit line to implicit form in 2D. -! -!# Introduction -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: finds if an implicit point is degenerate in 2D. -! -!# Introduction -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Parameters: -! -! Input, real ( kind = 8 ) A, B, C, the implicit line parameters. -! -! Output, logical ( kind = 4 ) LINE_IMP_IS_DEGENERATE_2D, is true if the -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: determines where two implicit lines intersect in 2D. -! -!# Introduction -! -! The implicit form of a line in 2D is: -! -! A * X + B * Y + C = 0 -! -! Parameters: -! -! Input, real ( kind = 8 ) A1, B1, C1, define the first line. -! At least one of A1 and B1 must be nonzero. -! -! Input, real ( kind = 8 ) A2, B2, C2, define the second line. -! At least one of A2 and B2 must be nonzero. -! -! Output, integer ( kind = 4 ) IVAL, reports on the intersection. -! -! -1, both A1 and B1 were zero. -! -2, both A2 and B2 were zero. -! 0, no intersection, the lines are parallel. -! 1, one intersection point, returned in P. -! 2, infinitely many intersections, the lines are identical. -! -! Output, real ( kind = 8 ) P(2), if IVAL = 1, then P is -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: computes a line perpendicular to a line and through a point. -! -!# Introduction -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The input point P3 should NOT lie on the line (P1,P2). If it -! does, then the output value P4 will equal P3. -! -! P1-----P4-----------P2 -! | -! | -! P3 -! -! P4 is also the nearest point on the line (P1,P2) to the point P3. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! Input, real ( kind = 8 ) P3(2), a point (presumably not on the -! line (P1,P2)), through which the perpendicular must pass. -! -! Output, real ( kind = 8 ) P4(2), a point on the line (P1,P2), -! such that the line (P3,P4) is perpendicular to the line (P1,P2). -! -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: determines where two explicit lines intersect in 2D. -! -!# Introduction -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the first line. -! -! Input, real ( kind = 8 ) Q1(2), Q2(2), two points on the second line. -! -! Output, integer ( kind = 4 ) IVAL, reports on the intersection: -! 0, no intersection, the lines may be parallel or degenerate. -! 1, one intersection point, returned in P. -! 2, infinitely many intersections, the lines are identical. -! -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: distance ( line segment, point ) in 2D. -! -!# Introduction -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! The nearest point will satisfy the condition -! -! PN = (1-T) * P1 + T * P2. -! -! T will always be between 0 and 1. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. -! -! Input, real ( kind = 8 ) P(2), -! the point whose nearest neighbor on the line -! segment is to be determined. -! -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Aug 2022 -! summary: distance ( line segment, point ) in 3D. -! -!# Introduction -! -! Discussion: -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! The nearest point will satisfy the condition -! -! PN = (1-T) * P1 + T * P2. -! -! T will always be between 0 and 1. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(3), P2(3), the endpoints of the segment. -! -! Input, real ( kind = 8 ) P(3), the point whose nearest neighbor on -! the line segment is to be determined. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: signed distance ( exp line, point ) in 2D. -! -!# Introduction -! -! Discussion: -! -! The explicit form of a line in 2D is: -! -! the line through the points P1 and P2. -! -! The signed distance has two interesting properties: -! -! * The absolute value of the signed distance is the -! usual (Euclidean) distance. -! -! * Points with signed distance 0 lie on the line, -! points with a negative signed distance lie on one side -! of the line, -! points with a positive signed distance lie on the -! other side of the line. -! -! Assuming that C is nonnegative, then if a point is a positive -! distance away from the line, it is on the same side of the -! line as the point (0,0), and if it is a negative distance -! from the line, it is on the opposite side from (0,0). -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), two points on the line. -! -! Input, real ( kind = 8 ) P(2), the point whose signed distance is -! desired. -! -! 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 29 Aug 2022 -! summary: nearest point on line segment to point in 2D. -! -!# Introduction -! -! -! A line segment is the finite portion of a line that lies between -! two points P1 and P2. -! -! The nearest point will satisfy the condition -! -! PN = (1-T) * P1 + T * P2. -! -! T will always be between 0 and 1. -! -! Parameters: -! -! Input, real ( kind = 8 ) P1(2), P2(2), the endpoints of the line segment. -! -! Input, real ( kind = 8 ) P(2), the point whose nearest neighbor -! on the line segment is to be determined. -! -! Output, real ( kind = 8 ) PN(2), the point on the line segment which is -! nearest the point P. -! -! Output, real ( kind = 8 ) DIST, the distance from the point to the -! nearest point on the line segment. -! -! Output, real ( kind = 8 ) T, the relative position of the point PN -! 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 - -END MODULE Line_Method diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90 deleted file mode 100644 index 8c39b8877..000000000 --- a/src/modules/Geometry/src/ReferenceLine_Method.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 -! - -!> author: Vikas Sharma, Ph. D. -! date: 5 March 2021 -! summary: This submodule contains method for [[ReferenceLine_]] - -MODULE ReferenceLine_Method -USE BaseType, ONLY: ReferenceTopology_, & - ReferenceElement_, & - ReferenceLine_ - -USE GlobalData, ONLY: I4B, DFP, LGT - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: Initiate -PUBLIC :: ReferenceLine -PUBLIC :: ReferenceLine_Pointer -PUBLIC :: HighOrderElement_Line -PUBLIC :: Measure_Simplex_Line -PUBLIC :: Line_Quality -PUBLIC :: Quality_Line -PUBLIC :: LineName -PUBLIC :: RefLineCoord -PUBLIC :: RefCoord_Line -PUBLIC :: DEFAULT_Ref_LINE_COORD -PUBLIC :: FacetElements_Line -PUBLIC :: ElementType_Line -PUBLIC :: ElementOrder_Line -PUBLIC :: TotalNodesInElement_Line -PUBLIC :: TotalEntities_Line -PUBLIC :: FacetTopology_Line -PUBLIC :: ElementName_Line -PUBLIC :: MaxOrder_Line -PUBLIC :: GetFaceElemType_Line -PUBLIC :: GetEdgeConnectivity_Line -PUBLIC :: GetFaceConnectivity_Line - -#ifdef MAX_LINE_ORDER -INTEGER(I4B), PARAMETER :: MaxOrder_Line = MAX_LINE_ORDER -#else -INTEGER(I4B), PARAMETER :: MaxOrder_Line = 5_I4B -#endif - -#ifdef REF_LINE_IS_UNIT -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]) -#endif - -!---------------------------------------------------------------------------- -! ElementName -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-25 -! summary: Returns element name in character from element number/type - -INTERFACE - MODULE PURE FUNCTION ElementName_Line(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - CHARACTER(:), ALLOCATABLE :: ans - END FUNCTION ElementName_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetTopology_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns the facet topology of the given element type - -INTERFACE - MODULE PURE SUBROUTINE FacetTopology_Line(elemType, nptrs, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nptrs(:) - TYPE(ReferenceTopology_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetTopology_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalEntities_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total entities - -INTERFACE - MODULE PURE FUNCTION TotalEntities_Line(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans(4) - END FUNCTION TotalEntities_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! TotalNodesInElement_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns total nodes in element - -INTERFACE - MODULE PURE FUNCTION TotalNodesInElement_Line(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION TotalNodesInElement_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementOrder_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns order of element - -INTERFACE - MODULE PURE FUNCTION ElementOrder_Line(elemType) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B) :: ans - END FUNCTION ElementOrder_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! ElementType_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-22 -! summary: Returns ElementType for line from char - -INTERFACE - MODULE PURE FUNCTION ElementType_Line(elemName) RESULT(ans) - CHARACTER(*), INTENT(IN) :: elemName - INTEGER(I4B) :: ans - END FUNCTION ElementType_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetElements_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Line - MODULE SUBROUTINE FacetElements_Line1(refelem, ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Line1 -END INTERFACE FacetElements_Line - -!---------------------------------------------------------------------------- -! FacetElements_Line -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-03-21 -! summary: Get FacetElements - -INTERFACE FacetElements_Line - MODULE SUBROUTINE FacetElements_Line2(elemType, nsd, ans) - INTEGER(I4B), INTENT(IN) :: elemType - INTEGER(I4B), INTENT(IN) :: nsd - TYPE(ReferenceElement_), INTENT(INOUT) :: ans(:) - END SUBROUTINE FacetElements_Line2 -END INTERFACE FacetElements_Line - -!---------------------------------------------------------------------------- -! LineName -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Returns the integer name of reference line for given order - -INTERFACE LineName - MODULE PURE FUNCTION LineName1(order) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B) :: ans - END FUNCTION LineName1 -END INTERFACE LineName - -!---------------------------------------------------------------------------- -! Initiate@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This subroutine constructs an instance of line reference element -! -!# Introduction -! This routine constructs an instance of [[ReferenceLine_]] -! element of order equal to 1. -! -! - `xij` denotes the nodal coordinate, if it is not present than RESHAPE( -! [-1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 2] ) is used. -! -!@note -! Note that SIZE(xij,1) should be equal to 3, i.e., x,y,z coord. Also note -! that this routine creats a linear element. -!@endnote -! -!### Usage -! -!```fortran -! type( ReferenceLine_ ) :: obj1 -! real( dfp ) :: xij( 3, 2 ) -! call random_number( xij ) -! call initiate( obj=obj1, nsd=3, xij ) -! call display( obj1, "obj1 : " ) -!``` - -INTERFACE Initiate - MODULE PURE SUBROUTINE Initiate_Ref_Line(obj, nsd, xij, domainName) - CLASS(ReferenceLine_), INTENT(INOUT) :: obj - !! The instance - INTEGER(I4B), INTENT(IN) :: nsd - !! Spatial dimension of the problem - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - !! Coords of element - CHARACTER(*), INTENT(IN), OPTIONAL :: domainName - !! Domain name - !! UNIT - !! BIUNIT - !! GENERAL - END SUBROUTINE Initiate_Ref_Line -END INTERFACE Initiate - -!---------------------------------------------------------------------------- -! ReferenceLine@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This routine constructs an instance of line reference element -! -!# Introduction -! This routine constructs an instance of [[ReferenceLine_]] element of order -! equal to 1. -! -! - `xij` denotes the nodal coordinate, if it is not present than RESHAPE( -! [-1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 2] ) is used. -! -!@note -! Note that SIZE(xij,1) should be equal to 3, i.e., x,y,z coord. Also note -! that this routine creats a linear element. -!@endnote -! -!### Usage -! -!```fortran -! type( ReferenceLine_ ) :: obj -! obj = ReferenceLine(nsd=3) -! call display( obj, 'obj : ' ) -!``` - -INTERFACE ReferenceLine - MODULE PURE FUNCTION Reference_Line(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - TYPE(ReferenceLine_) :: obj - CHARACTER(*), INTENT(IN), OPTIONAL :: domainName - !! Domain name - !! UNIT - !! BIUNIT - !! GENERAL - END FUNCTION Reference_Line -END INTERFACE ReferenceLine - -!---------------------------------------------------------------------------- -! ReferenceLine_Pointer@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This routine constructs an instance of line reference element -! -!# Introduction -! This routine constructs an instance of [[ReferenceLine_]] element of order -! equal to 1. -! -! - `xij` denotes the nodal coordinate, if it is not present than RESHAPE( -! [-1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP, 0.0_DFP, 0.0_DFP], [3, 2] ) is used. -! -!@note -! Note that SIZE(xij,1) should be equal to 3, i.e., x,y,z coord. Also note -! that this routine creats a linear element. -!@endnote -! -!### Usage -! -!```fortran -! class( ReferenceElement_ ), Pointer :: obj => NULL() -! obj => ReferenceLine_Pointer( nsd = 3 ) -! call display( obj, "obj : ") -!``` - -INTERFACE ReferenceLine_Pointer - MODULE FUNCTION Reference_Line_Pointer_1(nsd, xij, domainName) RESULT(obj) - INTEGER(I4B), INTENT(IN) :: nsd - REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :) - CLASS(ReferenceLine_), POINTER :: obj - CHARACTER(*), INTENT(IN), OPTIONAL :: domainName - !! Domain name - !! UNIT - !! BIUNIT - !! GENERAL - END FUNCTION Reference_Line_Pointer_1 -END INTERFACE ReferenceLine_Pointer - -!---------------------------------------------------------------------------- -! LagrangeElement@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 March 2021 -! summary: This function returns lagrange element on line -! -!# Introduction -! Returns lagrange line element of Higher order. By lagrange element we means -! standard finite elements, with equi-distance lagrange interpolation points. -! -!### Usage -! -!```fortran -! type( ReferenceLine_ ) :: obj1, obj3 -! real( dfp ) :: xij( 3, 2 ) -! call random_number( xij ) -! call initiate( obj=obj1, nsd=3, xij=xij ) -! call display( obj1, "obj1 : " ) -! call obj1%HighOrderElement( order=2, HighOrderobj=obj3 ) <--- -! call display( obj3, "Second order Lagrange Element : ") -!``` - -INTERFACE - MODULE SUBROUTINE HighOrderElement_Line(refelem, order, obj, ipType) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - !! Linear line element - INTEGER(I4B), INTENT(IN) :: order - !! order or generated element - CLASS(ReferenceElement_), INTENT(INOUT) :: obj - !! High order lagrange line element - INTEGER(I4B), INTENT(IN) :: ipType - END SUBROUTINE HighOrderElement_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! MeasureSimplex@Methods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 -! summary: This function returns the measure of linear line element -! -!# Introduction -! -! This function returns the measure of linear line element. Its generic form -! is given by [[ReferenceElement_Method:MeasureSimplex]] -! -! -!### Usage -! -!```fortran -! type( ReferenceLine_ ) :: obj -! real( dfp ) :: xij( 3, 2 ) -! call random_number( xij ) -! call initiate( obj=obj, nsd=3, xij=xij ) -! call display( MeasureSimplex(obj, obj%xij), "Measure :: ") -!``` - -INTERFACE - MODULE PURE FUNCTION Measure_Simplex_Line(refelem, xij) RESULT(Ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - REAL(DFP) :: Ans - END FUNCTION Measure_Simplex_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! line_quality@Methods -!---------------------------------------------------------------------------- - -INTERFACE Quality_Line - MODULE FUNCTION Line_Quality(refelem, xij, measure) RESULT(Ans) - CLASS(ReferenceElement_), INTENT(IN) :: refelem - REAL(DFP), INTENT(IN) :: xij(:, :) - INTEGER(I4B), INTENT(IN) :: measure - REAL(DFP) :: Ans - END FUNCTION Line_Quality -END INTERFACE Quality_Line - -!---------------------------------------------------------------------------- -! RefLineCoord -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference triangle - -INTERFACE RefCoord_Line - MODULE PURE FUNCTION RefLineCoord(refLine) RESULT(ans) - CHARACTER(*), INTENT(IN) :: refLine - !! "unit" - !! "biunit" - REAL(DFP) :: ans(1, 2) - END FUNCTION RefLineCoord -END INTERFACE RefCoord_Line - -!---------------------------------------------------------------------------- -! GetEdgeConnectivity -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-19 -! summary: Get the face connectivity of Line -! -!# Introduction -! -! This routine calls [[GetEdgeConnectivity_Line]] with opt=2 - -INTERFACE - MODULE PURE SUBROUTINE GetFaceConnectivity_Line(con, opt, order, nrow, ncol) - INTEGER(I4B), INTENT(INOUT) :: con(:, :) - !! Connectivity - !! The columns represents the Face number - !! The row represents a Face - !! con should be allocated by the user - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! This option is ignored now - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! order of element - !! Currently any order is valid - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow - !! Number of rows written in con - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol - !! Numbers of cols written in con - END SUBROUTINE GetFaceConnectivity_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! GetEdgeElemType@GeometryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2024-04-19 -! summary: Returns the element type of each face - -INTERFACE - MODULE PURE SUBROUTINE GetEdgeConnectivity_Line(con, opt, order, nrow, ncol) - INTEGER(I4B), INTENT(INOUT) :: con(:, :) - !! Connectivity - !! The columns represents the edge number - !! The row represents a edge - !! con should be allocated by the user - INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt - !! If opt = 1, then edge connectivity for hierarchial approximation - !! [1,2], [1,3], [2,3]. This is DEFAULT - !! If opt =2, then edge connectivity for Lagrangian approximation - !! [1,2], [2,3], [3,1] - INTEGER(I4B), OPTIONAL, INTENT(IN) :: order - !! order of element - !! Currently order is used only when opt=2 - !! Currently any order is valid - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: nrow - !! Number of rows written in con - INTEGER(I4B), OPTIONAL, INTENT(OUT) :: ncol - !! Numbers of cols written in con - END SUBROUTINE GetEdgeConnectivity_Line -END INTERFACE - -!---------------------------------------------------------------------------- -! 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_Line1(elemType, faceElemType, opt, & - tFaceNodes) - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! name of element - INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) - !! Element names of faces - INTEGER(I4B), OPTIONAL, 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_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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END MODULE ReferenceLine_Method diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index e1bf3d195..e2b2da49c 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -28,7 +28,6 @@ target_sources( ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/TetrahedronInterpolationUtility.F90 ${src_path}/HexahedronInterpolationUtility.F90 ${src_path}/PrismInterpolationUtility.F90 ${src_path}/PyramidInterpolationUtility.F90 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 100% rename from src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 rename to src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90 diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Tetrahedron/src/TetrahedronInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 rename to src/modules/Tetrahedron/src/TetrahedronInterpolationUtility.F90 diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index e25a3c572..9b3dde42b 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -36,6 +36,9 @@ 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) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index fb45f808a..ec7c0ca90 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -28,7 +28,6 @@ target_sources( ${src_path}/ReferenceElement_Method@VTKMethods.F90 ${src_path}/ReferencePoint_Method@Methods.F90 ${src_path}/Plane_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) diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 1fb054f21..b4c7fd745 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -18,9 +18,7 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90 - ${src_path}/TetrahedronInterpolationUtility@Methods.F90 - ${src_path}/HexahedronInterpolationUtility@Methods.F90 + PRIVATE ${src_path}/HexahedronInterpolationUtility@Methods.F90 ${src_path}/PrismInterpolationUtility@Methods.F90 ${src_path}/PyramidInterpolationUtility@Methods.F90 ${src_path}/InterpolationUtility@Methods.F90 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 100% rename from src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 rename to src/submodules/Tetrahedron/src/ReferenceTetrahedron_Method@Methods.F90 diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90 similarity index 99% rename from src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 rename to src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90 index fc5d4241e..1367badc1 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90 @@ -16,7 +16,7 @@ SUBMODULE(TetrahedronInterpolationUtility) Methods USE BaseMethod -USE QuadraturePoint_Tetrahedron_Solin, ONLY: & +USE Tetrahedron_QuadraturePoint_Solin, ONLY: & QuadratureNumberTetrahedronSolin, & QuadratureOrderTetrahedronSolin, & QuadraturePointTetrahedronSolin, & diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 similarity index 98% rename from src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 rename to src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 index b1fe4e11e..750732c01 100644 --- a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 +++ b/src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -MODULE QuadraturePoint_Tetrahedron_Solin +MODULE Tetrahedron_QuadraturePoint_Solin USE GlobalData, ONLY: DFP, I4B, LGT IMPLICIT NONE @@ -210,4 +210,4 @@ END SUBROUTINE QuadraturePointTetrahedronSolin ! !---------------------------------------------------------------------------- -END MODULE QuadraturePoint_Tetrahedron_Solin +END MODULE Tetrahedron_QuadraturePoint_Solin diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order1.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order1.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order10.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order10.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order11.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order11.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order12.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order12.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order13.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order13.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order14.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order14.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order15.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order15.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order16.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order16.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order17.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order17.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order18.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order18.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order19.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order19.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order2.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order2.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order20.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order20.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order21.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order21.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order3.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order3.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order4.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order4.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order5.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order5.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order6.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order6.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order7.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order7.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order8.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order8.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order9.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order9.F90 From 94ce91914def4789fe5392139bd72178c7d3dfb0 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 13:57:47 +0900 Subject: [PATCH 078/184] Adding Hexahedron --- src/modules/CMakeLists.txt | 3 +++ src/modules/Geometry/CMakeLists.txt | 1 - src/modules/Hexahedron/CMakeLists.txt | 21 ++++++++++++++++++ .../src/HexahedronInterpolationUtility.F90 | 0 .../src/ReferenceHexahedron_Method.F90 | 0 src/modules/Polynomial/CMakeLists.txt | 1 - src/submodules/CMakeLists.txt | 3 +++ src/submodules/Geometry/CMakeLists.txt | 1 - src/submodules/Hexahedron/CMakeLists.txt | 22 +++++++++++++++++++ ...HexahedronInterpolationUtility@Methods.F90 | 0 .../ReferenceHexahedron_Method@Methods.F90 | 0 src/submodules/Polynomial/CMakeLists.txt | 3 +-- 12 files changed, 50 insertions(+), 5 deletions(-) create mode 100644 src/modules/Hexahedron/CMakeLists.txt rename src/modules/{Polynomial => Hexahedron}/src/HexahedronInterpolationUtility.F90 (100%) rename src/modules/{Geometry => Hexahedron}/src/ReferenceHexahedron_Method.F90 (100%) create mode 100644 src/submodules/Hexahedron/CMakeLists.txt rename src/submodules/{Polynomial => Hexahedron}/src/HexahedronInterpolationUtility@Methods.F90 (100%) rename src/submodules/{Geometry => Hexahedron}/src/ReferenceHexahedron_Method@Methods.F90 (100%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index b0c63d20f..181780c5e 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -107,6 +107,9 @@ 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) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 31367b253..424795467 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -21,7 +21,6 @@ target_sources( PRIVATE ${src_path}/ReferenceElement_Method.F90 ${src_path}/ReferencePoint_Method.F90 ${src_path}/Plane_Method.F90 - ${src_path}/ReferenceHexahedron_Method.F90 ${src_path}/ReferencePrism_Method.F90 ${src_path}/ReferencePyramid_Method.F90 ${src_path}/Geometry_Method.F90) 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 100% rename from src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 rename to src/modules/Hexahedron/src/HexahedronInterpolationUtility.F90 diff --git a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 b/src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90 similarity index 100% rename from src/modules/Geometry/src/ReferenceHexahedron_Method.F90 rename to src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90 diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index e2b2da49c..51eb40e1f 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -28,7 +28,6 @@ target_sources( ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/HexahedronInterpolationUtility.F90 ${src_path}/PrismInterpolationUtility.F90 ${src_path}/PyramidInterpolationUtility.F90 ${src_path}/RecursiveNodesUtility.F90 diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index 9b3dde42b..b26997b2c 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -39,6 +39,9 @@ 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) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index ec7c0ca90..8f9e702ad 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -28,6 +28,5 @@ target_sources( ${src_path}/ReferenceElement_Method@VTKMethods.F90 ${src_path}/ReferencePoint_Method@Methods.F90 ${src_path}/Plane_Method@Methods.F90 - ${src_path}/ReferenceHexahedron_Method@Methods.F90 ${src_path}/ReferencePrism_Method@Methods.F90 ${src_path}/ReferencePyramid_Method@Methods.F90) 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 100% rename from src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 rename to src/submodules/Hexahedron/src/HexahedronInterpolationUtility@Methods.F90 diff --git a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90 similarity index 100% rename from src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 rename to src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90 diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index b4c7fd745..c30d96138 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -18,8 +18,7 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/HexahedronInterpolationUtility@Methods.F90 - ${src_path}/PrismInterpolationUtility@Methods.F90 + PRIVATE ${src_path}/PrismInterpolationUtility@Methods.F90 ${src_path}/PyramidInterpolationUtility@Methods.F90 ${src_path}/InterpolationUtility@Methods.F90 ${src_path}/LagrangePolynomialUtility@Methods.F90 From ca507958ddaebd83158e9b53e44d1cd4d006526a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 14:06:51 +0900 Subject: [PATCH 079/184] Adding Prism --- src/modules/CMakeLists.txt | 3 +++ src/modules/Geometry/CMakeLists.txt | 1 - src/modules/Polynomial/CMakeLists.txt | 1 - src/modules/Prism/CMakeLists.txt | 21 +++++++++++++++++++ .../src/PrismInterpolationUtility.F90 | 0 .../src/ReferencePrism_Method.F90 | 0 src/submodules/CMakeLists.txt | 3 +++ src/submodules/Geometry/CMakeLists.txt | 1 - src/submodules/Polynomial/CMakeLists.txt | 3 +-- src/submodules/Prism/CMakeLists.txt | 21 +++++++++++++++++++ .../src/PrismInterpolationUtility@Methods.F90 | 0 .../src/ReferencePrism_Method@Methods.F90 | 0 12 files changed, 49 insertions(+), 5 deletions(-) create mode 100644 src/modules/Prism/CMakeLists.txt rename src/modules/{Polynomial => Prism}/src/PrismInterpolationUtility.F90 (100%) rename src/modules/{Geometry => Prism}/src/ReferencePrism_Method.F90 (100%) create mode 100644 src/submodules/Prism/CMakeLists.txt rename src/submodules/{Polynomial => Prism}/src/PrismInterpolationUtility@Methods.F90 (100%) rename src/submodules/{Geometry => Prism}/src/ReferencePrism_Method@Methods.F90 (100%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 181780c5e..d600f6a31 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -110,6 +110,9 @@ 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) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 424795467..ad1a5d9fc 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -21,7 +21,6 @@ target_sources( PRIVATE ${src_path}/ReferenceElement_Method.F90 ${src_path}/ReferencePoint_Method.F90 ${src_path}/Plane_Method.F90 - ${src_path}/ReferencePrism_Method.F90 ${src_path}/ReferencePyramid_Method.F90 ${src_path}/Geometry_Method.F90) diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index 51eb40e1f..b3bb46879 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -28,7 +28,6 @@ target_sources( ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/PrismInterpolationUtility.F90 ${src_path}/PyramidInterpolationUtility.F90 ${src_path}/RecursiveNodesUtility.F90 ${src_path}/PolynomialUtility.F90) 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 100% rename from src/modules/Polynomial/src/PrismInterpolationUtility.F90 rename to src/modules/Prism/src/PrismInterpolationUtility.F90 diff --git a/src/modules/Geometry/src/ReferencePrism_Method.F90 b/src/modules/Prism/src/ReferencePrism_Method.F90 similarity index 100% rename from src/modules/Geometry/src/ReferencePrism_Method.F90 rename to src/modules/Prism/src/ReferencePrism_Method.F90 diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index b26997b2c..292cae64d 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -42,6 +42,9 @@ 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) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index 8f9e702ad..bde0680b5 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -28,5 +28,4 @@ target_sources( ${src_path}/ReferenceElement_Method@VTKMethods.F90 ${src_path}/ReferencePoint_Method@Methods.F90 ${src_path}/Plane_Method@Methods.F90 - ${src_path}/ReferencePrism_Method@Methods.F90 ${src_path}/ReferencePyramid_Method@Methods.F90) diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index c30d96138..0ea996740 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -18,8 +18,7 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/PrismInterpolationUtility@Methods.F90 - ${src_path}/PyramidInterpolationUtility@Methods.F90 + PRIVATE ${src_path}/PyramidInterpolationUtility@Methods.F90 ${src_path}/InterpolationUtility@Methods.F90 ${src_path}/LagrangePolynomialUtility@Methods.F90 ${src_path}/HierarchicalPolynomialUtility@Methods.F90 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 100% rename from src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 rename to src/submodules/Prism/src/PrismInterpolationUtility@Methods.F90 diff --git a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 b/src/submodules/Prism/src/ReferencePrism_Method@Methods.F90 similarity index 100% rename from src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 rename to src/submodules/Prism/src/ReferencePrism_Method@Methods.F90 From 9646b85fe2ed60df0f90c3e93d474b7dc9d2b1fa Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 14:20:45 +0900 Subject: [PATCH 080/184] Adding Pyramid --- src/modules/CMakeLists.txt | 3 +++ src/modules/Geometry/CMakeLists.txt | 1 - src/modules/Polynomial/CMakeLists.txt | 1 - src/modules/Pyramid/CMakeLists.txt | 22 +++++++++++++++++++ .../src/PyramidInterpolationUtility.F90 | 0 .../src/ReferencePyramid_Method.F90 | 0 src/submodules/CMakeLists.txt | 3 +++ src/submodules/Geometry/CMakeLists.txt | 3 +-- src/submodules/Polynomial/CMakeLists.txt | 3 +-- src/submodules/Pyramid/CMakeLists.txt | 22 +++++++++++++++++++ .../PyramidInterpolationUtility@Methods.F90 | 0 .../src/ReferencePyramid_Method@Methods.F90 | 0 12 files changed, 52 insertions(+), 6 deletions(-) create mode 100644 src/modules/Pyramid/CMakeLists.txt rename src/modules/{Polynomial => Pyramid}/src/PyramidInterpolationUtility.F90 (100%) rename src/modules/{Geometry => Pyramid}/src/ReferencePyramid_Method.F90 (100%) create mode 100644 src/submodules/Pyramid/CMakeLists.txt rename src/submodules/{Polynomial => Pyramid}/src/PyramidInterpolationUtility@Methods.F90 (100%) rename src/submodules/{Geometry => Pyramid}/src/ReferencePyramid_Method@Methods.F90 (100%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index d600f6a31..ab97d3300 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -113,6 +113,9 @@ 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) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index ad1a5d9fc..20f127aa2 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -21,6 +21,5 @@ target_sources( PRIVATE ${src_path}/ReferenceElement_Method.F90 ${src_path}/ReferencePoint_Method.F90 ${src_path}/Plane_Method.F90 - ${src_path}/ReferencePyramid_Method.F90 ${src_path}/Geometry_Method.F90) diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index b3bb46879..2404014d2 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -28,7 +28,6 @@ target_sources( ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/PyramidInterpolationUtility.F90 ${src_path}/RecursiveNodesUtility.F90 ${src_path}/PolynomialUtility.F90) 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 100% rename from src/modules/Polynomial/src/PyramidInterpolationUtility.F90 rename to src/modules/Pyramid/src/PyramidInterpolationUtility.F90 diff --git a/src/modules/Geometry/src/ReferencePyramid_Method.F90 b/src/modules/Pyramid/src/ReferencePyramid_Method.F90 similarity index 100% rename from src/modules/Geometry/src/ReferencePyramid_Method.F90 rename to src/modules/Pyramid/src/ReferencePyramid_Method.F90 diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index 292cae64d..2b7c960ff 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -45,6 +45,9 @@ 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) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index bde0680b5..e37606802 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -27,5 +27,4 @@ target_sources( ${src_path}/ReferenceElement_Method@EnquireMethods.F90 ${src_path}/ReferenceElement_Method@VTKMethods.F90 ${src_path}/ReferencePoint_Method@Methods.F90 - ${src_path}/Plane_Method@Methods.F90 - ${src_path}/ReferencePyramid_Method@Methods.F90) + ${src_path}/Plane_Method@Methods.F90) diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 0ea996740..c1588532b 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -18,8 +18,7 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${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 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 100% rename from src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 rename to src/submodules/Pyramid/src/PyramidInterpolationUtility@Methods.F90 diff --git a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 b/src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90 similarity index 100% rename from src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 rename to src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90 From f87a35f7ee5cb01d8c2e70a5e3b26551bfc03931 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 10 Oct 2025 15:24:45 +0900 Subject: [PATCH 081/184] Adding Point --- src/modules/CMakeLists.txt | 3 +++ src/modules/Geometry/CMakeLists.txt | 1 - src/modules/Point/CMakeLists.txt | 19 ++++++++++++++++++ .../src/ReferencePoint_Method.F90 | 0 src/submodules/CMakeLists.txt | 3 +++ src/submodules/Geometry/CMakeLists.txt | 1 - src/submodules/Point/CMakeLists.txt | 20 +++++++++++++++++++ .../src/ReferencePoint_Method@Methods.F90 | 0 8 files changed, 45 insertions(+), 2 deletions(-) create mode 100644 src/modules/Point/CMakeLists.txt rename src/modules/{Geometry => Point}/src/ReferencePoint_Method.F90 (100%) create mode 100644 src/submodules/Point/CMakeLists.txt rename src/submodules/{Geometry => Point}/src/ReferencePoint_Method@Methods.F90 (100%) diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index ab97d3300..2a7bd314a 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -95,6 +95,9 @@ 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) diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 20f127aa2..6158cffd4 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -19,7 +19,6 @@ 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}/Plane_Method.F90 ${src_path}/Geometry_Method.F90) 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/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index 2b7c960ff..f0eb632a9 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -27,6 +27,9 @@ 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) diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index e37606802..d49cf928f 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -26,5 +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}/Plane_Method@Methods.F90) 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 From 603b502bcf2d10a5d6b0c5b42a4fbcce53432654 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 08:06:48 +0900 Subject: [PATCH 082/184] Formatting in BaseType --- src/modules/BaseType/src/BaseType.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 74b931410..f52121798 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1262,8 +1262,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() @@ -1944,6 +1944,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: unscaledLobatto = UnscaledLobattoPolynomial INTEGER(I4B) :: hermit = HermitPolynomial INTEGER(I4B) :: ultraspherical = UltrasphericalPolynomial + INTEGER(I4B) :: default = Monomial END TYPE PolynomialOpt_ TYPE(PolynomialOpt_), PARAMETER :: TypePolynomialOpt = PolynomialOpt_() @@ -1953,7 +1954,7 @@ END FUNCTION iface_MatrixFunction !---------------------------------------------------------------------------- TYPE :: QuadratureOpt_ - INTEGER(I4B) :: equidistance = EquidistanceQP + INTEGER(I4B) :: Equidistance = EquidistanceQP INTEGER(I4B) :: Gauss = GaussQP INTEGER(I4B) :: GaussLegendre = GaussLegendreQP INTEGER(I4B) :: GaussLegendreLobatto = GaussLegendreLobattoQP @@ -1987,6 +1988,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: BlythPozChebyshev = BlythPozChebyshevQP INTEGER(I4B) :: IsaacLegendre = IsaacLegendreQP INTEGER(I4B) :: IsaacChebyshev = IsaacChebyshevQP + INTEGER(I4B) :: default = GaussLegendreQP END TYPE QuadratureOpt_ TYPE(QuadratureOpt_), PARAMETER :: TypeQuadratureOpt = QuadratureOpt_() From b92a3c26ac79ad1fc11a844de5d2ef6995257e64 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 09:29:07 +0900 Subject: [PATCH 083/184] Formatting in ElemshapeData_Lagrange@Methods --- .../ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 index f2da9c9b5..3d8da941e 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 @@ -18,9 +18,9 @@ SUBMODULE(ElemShapeData_Lagrange) Methods USE InputUtility, ONLY: Input -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate, & - Refelem_GetFaceElemType => GetFaceElemType, & - Refelem_RefCoord_ => RefCoord_ +USE ReferenceElement_Method, ONLY: & + Refelem_Initiate => Initiate, Refelem_GetFaceElemType => GetFaceElemType, & + Refelem_RefCoord_ => RefCoord_ USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE From d399f90afb3caf3acfca2d7f7606f11f5d145f3c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 10:15:08 +0900 Subject: [PATCH 084/184] Updating errors.F90 --- .../ElemshapeData_Hierarchical@Methods.F90 | 6 +- .../src/LineInterpolationUtility@Methods.F90 | 61 +++++++++---------- src/submodules/include/errors.F90 | 14 +++-- 3 files changed, 43 insertions(+), 38 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 index 44fb5a0a0..94b39a313 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 @@ -45,6 +45,10 @@ IMPLICIT NONE +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = "ElemshapeData_Hierarchical@Methods.F90" +#endif + CONTAINS !---------------------------------------------------------------------------- @@ -154,7 +158,7 @@ ans=faceRefelemCoord, nrow=nrow, ncol=ncol) #ifdef DEBUG_VER -CALL AssertError1(.FALSE., myName, & +CALL AssertError1(.FALSE., myName, modName, __LINE__, & "This is routine is under development") #endif diff --git a/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 index b831c0f1b..c24b478cf 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 @@ -22,6 +22,8 @@ elmopt => TypeElemNameOpt USE GlobalData, ONLY: stderr +USE ErrorHandling, ONLY: Errormsg +USE Display_Method, ONLY: ToString USE StringUtility, ONLY: UpperCase @@ -41,8 +43,6 @@ LagrangeCoeff, & LagrangeVandermonde_ -USE ErrorHandling, ONLY: ErrorMsg - USE LegendrePolynomialUtility, ONLY: LegendreQuadrature USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature @@ -58,16 +58,17 @@ USE F95_BLAS, ONLY: GEMM #ifndef USE_BLAS95 - USE SwapUtility, ONLY: Swap - #else - USE F95_BLAS, ONLY: Swap - #endif IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = "LineInterpolationUtility@Methods.F90" +#endif + CONTAINS !---------------------------------------------------------------------------- @@ -824,6 +825,11 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- 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 @@ -831,14 +837,9 @@ END SUBROUTINE handle_error tsize = SIZE(xij, 2) #ifdef DEBUG_VER - -IF (tsize .NE. order + 1) THEN - CALL Errormsg(msg="Size(xij, 1) .NE. order+1 ", & - routine="LagrangeEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - +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) @@ -903,6 +904,11 @@ END SUBROUTINE handle_error !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Line2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line2_()" +LOGICAL(LGT) :: isok +#endif + LOGICAL(LGT) :: firstCall0 REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) INTEGER(I4B) :: ii, orthopol0, aint, bint @@ -911,14 +917,9 @@ END SUBROUTINE handle_error ncol = SIZE(xij, 2) #ifdef DEBUG_VER - -IF (ncol .NE. order + 1) THEN - CALL Errormsg(msg="Size(xij, 1) .NE. order+1 ", & - routine="LagrangeEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - +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) @@ -979,6 +980,8 @@ END SUBROUTINE handle_error MODULE PROCEDURE BasisEvalAll_Line1_ #ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BasisEvalAll_Line1_()" +LOGICAL(LGT) :: isok CHARACTER(1) :: astr #endif @@ -988,15 +991,9 @@ END SUBROUTINE handle_error tsize = order + 1 #ifdef DEBUG_VER - -astr = UpperCase(refLine(1:1)) -IF (astr .EQ. "U") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - +isok = astr .EQ. "B" +CALL AssertError1(isok, myName, modName, __LINE__, & + "refLine should be BIUNIT") #endif basisType0 = Input(default=polyopt%Monomial, option=basisType) @@ -1971,4 +1968,6 @@ END SUBROUTINE handle_error ! !---------------------------------------------------------------------------- +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/include/errors.F90 b/src/submodules/include/errors.F90 index 2a20f1a35..97548e3d2 100644 --- a/src/submodules/include/errors.F90 +++ b/src/submodules/include/errors.F90 @@ -2,15 +2,17 @@ ! AssertError1 !---------------------------------------------------------------------------- -SUBROUTINE AssertError1(a, myName, msg) +SUBROUTINE AssertError1(a, myName, modName, lineNo, msg) + USE GlobalData, ONLY: I4B, stderr + USE ErrorHandling, ONLY: Errormsg LOGICAL, INTENT(IN) :: a - CHARACTER(*), INTENT(IN) :: myName - CHARACTER(*), INTENT(IN) :: msg + CHARACTER(*), INTENT(IN) :: myName, modName, msg + INTEGER(I4B), INTENT(IN) :: lineNo IF (.NOT. a) THEN - CALL Errormsg(msg=msg, file=__FILE__, routine=myName, & - line=__LINE__, unitno=stderr) - RETURN + CALL Errormsg(msg=msg, file=modName, routine=myName, & + line=lineNo, unitno=stderr) + STOP END IF END SUBROUTINE AssertError1 From 58e4ec0cb8543f970f0982630078e9c3bb6cf561 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 17:35:59 +0900 Subject: [PATCH 085/184] Formatting --- src/modules/Line/src/LineInterpolationUtility.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index bccf725cf..17c7e59c1 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -1007,8 +1007,9 @@ END FUNCTION LagrangeGradientEvalAll_Line1 !---------------------------------------------------------------------------- INTERFACE LagrangeGradientEvalAll_Line_ - MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_(order, x, xij, ans, & - dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, lambda) + 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(:, :) From 69ef03acc9d9c96cd0ae36267cea8d022fcf5126 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 17:36:14 +0900 Subject: [PATCH 086/184] Formatting --- ...iangleInterpolationUtility@LagrangeBasisMethods.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index ff0ef79d0..8c5c84b4c 100644 --- a/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -360,12 +360,10 @@ 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) - +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 !---------------------------------------------------------------------------- From 06a646207b30c94f085802f65887d45ede0b113f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 17:43:59 +0900 Subject: [PATCH 087/184] Formatting in TriangleInterpolationUtility --- src/modules/Triangle/src/TriangleInterpolationUtility.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 index 2c2837bbd..1ebd46cb9 100644 --- a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 @@ -1672,9 +1672,9 @@ END FUNCTION LagrangeGradientEvalAll_Triangle1 ! 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) + 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(:, :) From 80bed3cfa1e30256d35b848c0f1c8a986a01ad3c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 19:28:44 +0900 Subject: [PATCH 088/184] Formatting in QuadrangleInterpolationUtility --- .../Quadrangle/src/QuadrangleInterpolationUtility.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index 039021807..dd0641979 100644 --- a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -2600,9 +2600,9 @@ END FUNCTION QuadraturePoint_Quadrangle4 !---------------------------------------------------------------------------- INTERFACE QuadraturePoint_Quadrangle_ - MODULE SUBROUTINE QuadraturePoint_Quadrangle1_(nipsx, nipsy, quadType1, & - quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, & - lambda2, ans, nrow, ncol) + 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) From 4abd37ba3df86bc31b33fc072019919ebf7030bc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 11 Oct 2025 20:31:10 +0900 Subject: [PATCH 089/184] Formatting in QuadrangleInterpolation --- .../src/QuadrangleInterpolationUtility.F90 | 31 +++++++++++-------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index dd0641979..735ececb0 100644 --- a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -546,8 +546,9 @@ END SUBROUTINE LagrangeCoeff_Quadrangle5_ ! 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) + 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) @@ -587,8 +588,9 @@ END FUNCTION LagrangeEvalAll_Quadrangle1 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Quadrangle_ - MODULE SUBROUTINE LagrangeEvalAll_Quadrangle1_(order, x, xij, ans, tsize, & - coeff, firstCall, basisType, alpha, beta, lambda) + 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) @@ -635,8 +637,9 @@ END SUBROUTINE LagrangeEvalAll_Quadrangle1_ ! summary: Evaluate all Lagrange polynomials of order n at several points INTERFACE LagrangeEvalAll_Quadrangle - MODULE FUNCTION LagrangeEvalAll_Quadrangle2(order, x, xij, coeff, & - firstCall, basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Quadrangle2( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -671,8 +674,9 @@ END FUNCTION LagrangeEvalAll_Quadrangle2 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Quadrangle_ - MODULE SUBROUTINE LagrangeEvalAll_Quadrangle2_(order, x, xij, ans, & - nrow, ncol, coeff, firstCall, basisType, alpha, beta, lambda) + 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(:, :) @@ -715,8 +719,9 @@ END SUBROUTINE LagrangeEvalAll_Quadrangle2_ ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeGradientEvalAll_Quadrangle - MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1(order, x, xij, coeff, & - firstCall, basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -754,9 +759,9 @@ END FUNCTION LagrangeGradientEvalAll_Quadrangle1 !---------------------------------------------------------------------------- INTERFACE LagrangeGradientEvalAll_Quadrangle_ - MODULE SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_(order, x, xij, & - ans, dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, & - lambda) + 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(:, :) From bea8e346dc66f49f4ade018e07eebdaad5beed99 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 13 Oct 2025 10:34:07 +0900 Subject: [PATCH 090/184] Formatting in Triangle and Quadrangle Interpoltion --- .../src/QuadrangleInterpolationUtility.F90 | 19 ++++++++++--------- .../src/TriangleInterpolationUtility.F90 | 5 ++--- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index 735ececb0..b87f6c435 100644 --- a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -1061,8 +1061,8 @@ END FUNCTION EquidistanceInPoint_Quadrangle2 ! GaussJacobiRadauRight INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, & - xij, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION InterpolationPoint_Quadrangle1( & + order, ipType, layout, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of element INTEGER(I4B), INTENT(IN) :: ipType @@ -1087,8 +1087,8 @@ END FUNCTION InterpolationPoint_Quadrangle1 !---------------------------------------------------------------------------- INTERFACE InterpolationPoint_Quadrangle_ - MODULE SUBROUTINE InterpolationPoint_Quadrangle1_(order, ipType, ans, & - nrow, ncol, layout, xij, alpha, beta, lambda) + 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 @@ -1139,8 +1139,9 @@ END SUBROUTINE InterpolationPoint_Quadrangle1_ ! also follow the same convention. Please read Gmsh manual on this topic. INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle2(p, q, ipType1, ipType2, & - layout, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) + MODULE FUNCTION InterpolationPoint_Quadrangle2( & + p, q, ipType1, ipType2, layout, xij, alpha1, beta1, lambda1, alpha2, & + beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p !! order of element in x direction INTEGER(I4B), INTENT(IN) :: q @@ -1175,9 +1176,9 @@ END FUNCTION InterpolationPoint_Quadrangle2 !---------------------------------------------------------------------------- INTERFACE InterpolationPoint_Quadrangle_ - MODULE SUBROUTINE InterpolationPoint_Quadrangle2_(p, q, ipType1, ipType2, & - ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, & - alpha2, beta2, lambda2) + 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 diff --git a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 index 1ebd46cb9..7a2ab7be5 100644 --- a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 @@ -542,9 +542,8 @@ END FUNCTION InterpolationPoint_Triangle !---------------------------------------------------------------------------- INTERFACE - MODULE SUBROUTINE InterpolationPoint_Triangle_(order, ipType, ans, nrow, & - ncol, layout, xij, & - alpha, beta, lambda) + 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 From 38662a3aedbfbe87222283a8d9b1d631f75d5fd1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 13 Oct 2025 13:44:46 +0900 Subject: [PATCH 091/184] Formatting in LineInterpolation --- .../Line/src/LineInterpolationUtility.F90 | 49 +++++++------------ 1 file changed, 17 insertions(+), 32 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index 17c7e59c1..3625a7188 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -449,9 +449,8 @@ END SUBROUTINE EquidistancePoint_Line2_ !- `layout=INCREASING` points are arranged in increasing order INTERFACE InterpolationPoint_Line - MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & - layout, xij, alpha, beta, lambda) RESULT(ans) - !! + 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 @@ -483,25 +482,25 @@ END FUNCTION InterpolationPoint_Line1 !> 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) + MODULE SUBROUTINE InterpolationPoint_Line1_( & + order, ipType, ans, nrow, ncol, layout, xij, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! Order of interpolation INTEGER(I4B), INTENT(IN) :: ipType !! Interpolation point type - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto REAL(DFP), INTENT(INOUT) :: ans(:, :) !! interpolation points in xij format - !! size(ans,1) = 1 - !! size(ans,2) = order+1 + !! size(ans,1) = 1, size(ans,2) = order+1 INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns written to ans CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" + !! "VEFC" or "INCREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! domain of interpolation REAL(DFP), OPTIONAL, INTENT(IN) :: alpha @@ -522,26 +521,16 @@ END SUBROUTINE InterpolationPoint_Line1_ ! summary: Returns the interpolation point INTERFACE InterpolationPoint_Line - MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & - layout, alpha, beta, lambda) RESULT(ans) - !! + 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" + !! "VEFC", "INCREASING", "DECREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -558,14 +547,12 @@ END FUNCTION InterpolationPoint_Line2 !---------------------------------------------------------------------------- INTERFACE InterpolationPoint_Line_ - MODULE SUBROUTINE InterpolationPoint_Line2_(order, ipType, ans, tsize, & - xij, layout, alpha, beta, lambda) - !! + 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 + !! Interpolation point type, see TypeInterpolationOpt REAL(DFP), INTENT(INOUT) :: ans(:) !! one dimensional interpolation point INTEGER(I4B), INTENT(OUT) :: tsize @@ -573,9 +560,7 @@ MODULE SUBROUTINE InterpolationPoint_Line2_(order, ipType, ans, tsize, & REAL(DFP), INTENT(IN) :: xij(2) !! end points CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - !! "DECREASING" + !! "VEFC", "INCREASING", "DECREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta From 725ad225a0eb9e51eed26e95a0f75de3ede4c342 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 14 Oct 2025 15:07:58 +0900 Subject: [PATCH 092/184] Updating SwapUtility Minor --- src/modules/Utility/src/SwapUtility.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90 index 0304fc55f..6a0ac2d88 100644 --- a/src/modules/Utility/src/SwapUtility.F90 +++ b/src/modules/Utility/src/SwapUtility.F90 @@ -19,6 +19,10 @@ MODULE SwapUtility USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, & DFPC, LGT, I4B +#ifdef USE_BLAS95 +USE F95_BLAS, ONLY: SWAP +#endif + IMPLICIT NONE PRIVATE From ba0f5a6c360d21d9f36ac43f1431bcb7cfae9f3e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 14 Oct 2025 15:08:26 +0900 Subject: [PATCH 093/184] Formatting in LineInterpolationUtility --- .../src/LineInterpolationUtility@Methods.F90 | 23 ++++++++----------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 index c24b478cf..4121672a4 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 @@ -374,21 +374,18 @@ MODULE PROCEDURE InterpolationPoint_Line1 INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1 -END IF - +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) - +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 !---------------------------------------------------------------------------- @@ -399,9 +396,9 @@ 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) +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 !---------------------------------------------------------------------------- From ae5e96422bb084212d897a5a84b102c098db3f69 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 14 Oct 2025 15:57:37 +0900 Subject: [PATCH 094/184] Updating SwapUtility --- src/modules/Utility/src/SwapUtility.F90 | 316 +++++++++++++++--- .../Utility/src/SwapUtility@Methods.F90 | 225 +++++++++---- 2 files changed, 446 insertions(+), 95 deletions(-) diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90 index 6a0ac2d88..3b83c1246 100644 --- a/src/modules/Utility/src/SwapUtility.F90 +++ b/src/modules/Utility/src/SwapUtility.F90 @@ -31,7 +31,7 @@ MODULE SwapUtility PUBLIC :: Swap_ !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -42,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. @@ -68,7 +101,7 @@ END SUBROUTINE Swap_r32 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -82,7 +115,7 @@ END SUBROUTINE Swap_r64 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -94,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 @@ -102,7 +147,7 @@ END SUBROUTINE Swap_r64v #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -113,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) @@ -137,7 +219,7 @@ END SUBROUTINE Swap_Int128v #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -151,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) @@ -163,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(:, :) @@ -173,7 +263,7 @@ END SUBROUTINE Swap_cm END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -187,7 +277,7 @@ END SUBROUTINE Swap_r32m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -201,7 +291,7 @@ END SUBROUTINE Swap_r64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -212,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) @@ -239,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) @@ -254,7 +378,7 @@ END SUBROUTINE masked_Swap_r32s END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -269,7 +393,7 @@ END SUBROUTINE masked_Swap_r64s END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -281,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 @@ -299,7 +453,7 @@ END SUBROUTINE masked_Swap_Int64s END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -316,7 +470,7 @@ END SUBROUTINE masked_Swap_Int128s #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -331,7 +485,7 @@ END SUBROUTINE masked_Swap_r32v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -346,7 +500,7 @@ END SUBROUTINE masked_Swap_r64v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -358,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(:) @@ -376,7 +560,7 @@ END SUBROUTINE masked_Swap_Int64v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -393,7 +577,7 @@ END SUBROUTINE masked_Swap_Int128v #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -408,7 +592,7 @@ END SUBROUTINE masked_Swap_r32m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -423,7 +607,7 @@ END SUBROUTINE masked_Swap_r64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -435,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(:, :) @@ -453,7 +667,7 @@ END SUBROUTINE masked_Swap_Int64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -470,7 +684,7 @@ END SUBROUTINE masked_Swap_Int128m #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -501,7 +715,7 @@ END SUBROUTINE Swap_index1 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -533,7 +747,7 @@ END SUBROUTINE Swap_index2 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -561,7 +775,6 @@ MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, 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_ !---------------------------------------------------------------------------- @@ -584,7 +797,7 @@ END SUBROUTINE Swap_index_2 END INTERFACE Swap_ !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -619,7 +832,7 @@ END SUBROUTINE Swap_index3 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -651,7 +864,25 @@ MODULE PURE SUBROUTINE Swap_index_3(a, b, i1, i2, 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 @@ -670,7 +901,7 @@ END SUBROUTINE Swap_index_4 END INTERFACE Swap_ !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -684,7 +915,6 @@ END SUBROUTINE Swap_index_4 ! `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) @@ -705,7 +935,7 @@ END SUBROUTINE Swap_index4 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -742,7 +972,7 @@ END SUBROUTINE Swap_index5 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -779,7 +1009,7 @@ END SUBROUTINE Swap_index6 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -813,7 +1043,17 @@ MODULE PURE SUBROUTINE Swap_index_5(a, b, i1, i2, i3, 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 diff --git a/src/submodules/Utility/src/SwapUtility@Methods.F90 b/src/submodules/Utility/src/SwapUtility@Methods.F90 index c891eb817..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(REAL64), 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 From d6cc5500c3430d4c78db4b403d6409f68a1eeb02 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 15 Oct 2025 07:23:54 +0900 Subject: [PATCH 095/184] Adding ReverseUtility --- src/modules/Utility/CMakeLists.txt | 1 + src/modules/Utility/src/ReverseUtility.F90 | 255 ++++++++++++++++++ src/submodules/Utility/CMakeLists.txt | 3 +- .../Utility/src/Reverse/ReverseMatrix.F90 | 51 ++++ .../Utility/src/Reverse/ReverseVector.F90 | 30 +++ .../Utility/src/ReverseUtility@Methods.F90 | 196 ++++++++++++++ 6 files changed, 535 insertions(+), 1 deletion(-) create mode 100644 src/modules/Utility/src/ReverseUtility.F90 create mode 100644 src/submodules/Utility/src/Reverse/ReverseMatrix.F90 create mode 100644 src/submodules/Utility/src/Reverse/ReverseVector.F90 create mode 100644 src/submodules/Utility/src/ReverseUtility@Methods.F90 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/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/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/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 From 6a98a634047b98568e9ed56dfa662015ddc2daed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 16 Oct 2025 08:16:40 +0900 Subject: [PATCH 096/184] Formatting in QuadraturePoint_Method --- .../src/QuadraturePoint_Method@FacetQuadratureMethods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 index 4910b80b2..4f2cbc017 100644 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 @@ -94,7 +94,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_InitiateFacetQuadrature3 -INTEGER(I4B) :: topo, nrow, ncol, nipsx(1), nipsy(1), nipsz(1), tsize, nsd +INTEGER(I4B) :: topo, nrow, ncol, nipsx(1), nsd INTEGER(I4B) :: facecon(ReferenceElementInfo%maxPoints, & ReferenceElementInfo%maxEdges) REAL(DFP) :: x1(3), x2(3) From 64afb37396eebbb739120576fc2afda85779ed92 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 16 Oct 2025 08:17:03 +0900 Subject: [PATCH 097/184] Updating ElemshapeData_SetMethods updating elemsd_Set2 --- .../ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 index d30bc6858..a56e93c53 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -244,10 +244,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Set2 -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) + CALL SetJacobian(obj=facetobj, val=facetval, dNdXi=facetdNdXi) CALL SetJs(obj=facetobj) CALL SetBarycentricCoord(obj=facetobj, val=facetval, N=facetN) From a0a260a75a5c095a3d62699b730ac63add400bfb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 17 Oct 2025 14:41:02 +0900 Subject: [PATCH 098/184] Formatting in LineInterplationUtility --- src/modules/Line/src/LineInterpolationUtility.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index 3625a7188..3ee296382 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -1479,8 +1479,8 @@ END FUNCTION HeirarchicalGradientBasis_Line2 !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Line_ - MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_(order, xij, refLine, & - orient, ans, dim1, dim2, dim3) + 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(:, :) From ed9efa5dec2de7f425a67030095de986dbeda4e5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 17 Oct 2025 16:19:35 +0900 Subject: [PATCH 099/184] Updating REallocateUtility Updating reallocate3.F90 --- .../Utility/src/Reallocate/reallocate3.F90 | 50 ++++++++++++++++--- 1 file changed, 42 insertions(+), 8 deletions(-) diff --git a/src/submodules/Utility/src/Reallocate/reallocate3.F90 b/src/submodules/Utility/src/Reallocate/reallocate3.F90 index cf5b6380e..600555152 100644 --- a/src/submodules/Utility/src/Reallocate/reallocate3.F90 +++ b/src/submodules/Utility/src/Reallocate/reallocate3.F90 @@ -1,25 +1,59 @@ -LOGICAL :: isok, abool -INTEGER(I4B) :: s(3), ii, jj, kk +LOGICAL :: isalloc, abool(3), ex, acase +INTEGER(I4B) :: s(3), ii, jj, kk, fac -isok = ALLOCATED(mat) +isalloc = ALLOCATED(mat) -IF (isok) THEN +! 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 = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 + abool(1) = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 - IF (abool) THEN + IF (abool(1)) THEN DEALLOCATE (mat) ALLOCATE (mat(i1, i2, i3)) END IF -ELSE + DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3) + mat(ii, jj, kk) = ZEROVALUE + END DO - ALLOCATE (mat(i1, i2, i3)) + RETURN +END IF +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 + From 870964791fa03007badacb43d4f88cab9baa0a55 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 17 Oct 2025 16:32:34 +0900 Subject: [PATCH 100/184] Updating RellocateUtility updating reallocate2 --- .../Utility/src/Reallocate/reallocate2.F90 | 65 ++++++++----------- .../Utility/src/Reallocate/reallocate3.F90 | 1 + 2 files changed, 29 insertions(+), 37 deletions(-) diff --git a/src/submodules/Utility/src/Reallocate/reallocate2.F90 b/src/submodules/Utility/src/Reallocate/reallocate2.F90 index 570150ba5..857e28cd8 100644 --- a/src/submodules/Utility/src/Reallocate/reallocate2.F90 +++ b/src/submodules/Utility/src/Reallocate/reallocate2.F90 @@ -1,23 +1,28 @@ -LOGICAL :: isok, abool, ex, acase +LOGICAL :: isalloc, abool(3), ex, acase INTEGER(I4B) :: s(2), ii, jj, fac -ex = .FALSE. -IF (PRESENT(isExpand)) ex = isExpand +isalloc = ALLOCATED(mat) -fac = 1 -IF (PRESENT(expandFactor)) fac = expandFactor - -isok = 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 -acase = isok .AND. (.NOT. ex) +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 = s(1) .NE. row .OR. s(2) .NE. col + abool(1) = s(1) .NE. row .OR. s(2) .NE. col - IF (abool) THEN + IF (abool(1)) THEN DEALLOCATE (mat) ALLOCATE (mat(row, col)) END IF @@ -25,42 +30,28 @@ DO CONCURRENT(ii=1:row, jj=1:col) mat(ii, jj) = ZEROVALUE END DO - RETURN + RETURN END IF -acase = isok .AND. ex - -IF (acase) THEN - - s = SHAPE(mat) +! If allocated and isExpand is true +fac = 1 +IF (PRESENT(expandFactor)) fac = expandFactor - abool = (s(1) .LT. row) .OR. & - (s(2) .LT. col) +s = SHAPE(mat) - IF (abool) THEN - DEALLOCATE (mat) - ALLOCATE (mat(row * fac, col * fac)) - END IF +abool(1) = s(1) .LT. row +abool(2) = s(2) .LT. col - DO CONCURRENT(ii=1:row, jj=1:col) - mat(ii, jj) = ZEROVALUE - END DO - RETURN +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 -ALLOCATE (mat(row * fac, col * fac)) - DO CONCURRENT(ii=1:row, jj=1:col) mat(ii, jj) = ZEROVALUE END DO -! IF (ALLOCATED(mat)) THEN -! IF ((SIZE(mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN -! DEALLOCATE (mat) -! ALLOCATE (mat(row, col)) -! END IF -! ELSE -! ALLOCATE (mat(row, col)) -! END IF diff --git a/src/submodules/Utility/src/Reallocate/reallocate3.F90 b/src/submodules/Utility/src/Reallocate/reallocate3.F90 index 600555152..7521165d0 100644 --- a/src/submodules/Utility/src/Reallocate/reallocate3.F90 +++ b/src/submodules/Utility/src/Reallocate/reallocate3.F90 @@ -34,6 +34,7 @@ RETURN END IF +! If allocated and isExpand is true fac = 1 IF (PRESENT(expandFactor)) fac = expandFactor From 3731e5327b3ccf467c8fde1d15e5deca562330c5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 18 Oct 2025 10:36:01 +0900 Subject: [PATCH 101/184] Formatting in QuadrangleInterpolation --- .../src/QuadrangleInterpolationUtility.F90 | 4 ++-- ...eInterpolationUtility@HierarchicalMethods.F90 | 16 +++++++++------- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index b87f6c435..4ba4db3ff 100644 --- a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -1999,8 +1999,8 @@ END FUNCTION HeirarchicalBasis_Quadrangle1 !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasis_Quadrangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle1_(pb, qb, pe3, pe4, & - qe1, qe2, xij, ans, nrow, ncol) + 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 diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 index 499748c23..b6e29a151 100644 --- a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 @@ -514,8 +514,9 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +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 !---------------------------------------------------------------------------- @@ -524,7 +525,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] -CALL HeirarchicalBasis_Quadrangle3_( & +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) @@ -536,7 +537,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Quadrangle1_( & +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 @@ -546,7 +547,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- MODULE PROCEDURE HeirarchicalBasis_Quadrangle2_ -CALL HeirarchicalBasis_Quadrangle1_( & +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_ @@ -563,7 +564,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ ALLOCATE (ans(1:nrow, 1:ncol)) -CALL HeirarchicalBasis_Quadrangle3_( & +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) @@ -592,7 +593,8 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ 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)) +CALL VertexBasis_Quadrangle3_(L1=L1, L2=L2, ans=ans, nrow=indx(1), & + ncol=indx(2)) ncol = indx(2) From cd94bb8f6d3b54f922443e4142e6831f42040076 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 18 Oct 2025 16:16:40 +0900 Subject: [PATCH 102/184] Updating QuadrangleInterpolation Adding HierarchicalDOF method --- .../src/QuadrangleInterpolationUtility.F90 | 27 + ...terpolationUtility@HierarchicalMethods.F90 | 495 ++++++++++++------ 2 files changed, 370 insertions(+), 152 deletions(-) diff --git a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index 4ba4db3ff..188cec7f7 100644 --- a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -90,6 +90,33 @@ MODULE QuadrangleInterpolationUtility 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@DOFMethods !---------------------------------------------------------------------------- diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 index b6e29a151..baf505d98 100644 --- a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 @@ -21,6 +21,30 @@ 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 !---------------------------------------------------------------------------- @@ -143,120 +167,191 @@ END SUBROUTINE VertexBasis_Quadrangle3_ INTEGER(I4B), PARAMETER :: maxP = 1, orient = 1 REAL(DFP), ALLOCATABLE :: L2(:, :), L1(:, :) -maxQ = MAX(qe1, qe2) +nrow = SIZE(x) +ncol = 0 +maxQ = MAX(qe1, qe2) aint = SIZE(y) -nrow = SIZE(x) 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) -CALL VerticalEdgeBasis_Quadrangle2_( & - qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=ncol, & - qe1Orient=orient, qe2Orient=orient) +! Left vertical +CALL LeftVerticalEdgeBasis_Quadrangle_( & + order=qe1, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, & + orient=orient, offset=ncol) +ncol = ncol + aint -DEALLOCATE (L2, L1) +! 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 VerticalEdgeBasis_Quadrangle2_( & - qe1, qe2, L1, L2, ans, nrow, ncol, qe1Orient, qe2Orient) - INTEGER(I4B), INTENT(IN) :: qe1 +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 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) !! Lobatto polynomials in x and y direction. REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(L1, 1), qe1 + qe2 - 2) INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns written to ans - INTEGER(I4B), INTENT(IN), OPTIONAL :: qe1Orient, qe2Orient + 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, cnt, ii - REAL(DFP) :: o1, o2 + INTEGER(I4B) :: k2, ii + REAL(DFP) :: o1 - o1 = REAL(-qe1Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & + o1 = REAL(-orient, kind=DFP) + ! Here we multiply by -1 because the left edge is oriented downwards ! in master element - o2 = REAL(qe2Orient, kind=DFP) - nrow = SIZE(L1, 1) - ncol = qe1 + qe2 - 2 - cnt = qe1 - 1 + nrow = SIZE(L1, 1) !! Number of points of evaluation + ncol = order - 1 !! these are internal DOFs on edge - !! left vertical - DO CONCURRENT(k2=2:qe1, ii=1:nrow) - ans(ii, k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2) + 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:qe2, ii=1:nrow) - ans(ii, cnt + k2 - 1) = (o2**k2) * L1(ii, 1) * L2(ii, k2) + 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 VerticalEdgeBasis_Quadrangle2_ +END SUBROUTINE RightVerticalEdgeBasis_Quadrangle_ !---------------------------------------------------------------------------- -! VerticalEdgeBasisGradient_Quadrangle +! LeftVerticalEdgeBasisGradient_Quadrangle !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 28 Oct 2022 ! summary: Returns the vertex basis functions on biunit quadrangle -PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_( & - qe1, qe2, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, qe1Orient, qe2Orient) - INTEGER(I4B), INTENT(IN) :: qe1 +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 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) !! Lobatto polynomials in x and y direction. REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) !! Lobatto polynomials in x and y direction. REAL(DFP), INTENT(INOUT) :: ans(:, :, :) !! dim1=SIZE(L1, 1) - !! dim2=qe1 + qe2 - 2 + !! dim2=order-1 !! dim3= 2 INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 !! range of data written to ans - INTEGER(I4B), INTENT(IN) :: qe1Orient, qe2Orient + 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, cnt, ii - REAL(DFP) :: o1, o2 + INTEGER(I4B) :: k2, ii + REAL(DFP) :: mysign - o1 = REAL(-qe1Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & + mysign = REAL(-orient, kind=DFP) + ! Here we multiply by -1 because the left edge is oriented downwards & ! in master element - o2 = REAL(qe2Orient, kind=DFP) dim1 = SIZE(L1, 1) - dim2 = qe1 + qe2 - 2 + dim2 = order - 1 dim3 = 2 - cnt = qe1 - 1 - - DO CONCURRENT(k2=2:qe1, ii=1:dim1) - ans(ii, k2 - 1, 1) = (o1**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2) - ans(ii, k2 - 1, 2) = (o1**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2) + DO CONCURRENT(k2=2:order, ii=1:dim1) + ans(ii, offset + k2 - 1, 1) = (mysign**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2) + ans(ii, offset + k2 - 1, 2) = (mysign**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2) END DO - DO CONCURRENT(k2=2:qe2, ii=1:dim1) - ans(ii, cnt + k2 - 1, 1) = (o2**(k2 - 1)) * dL1(ii, 1) * L2(ii, k2) - ans(ii, cnt + k2 - 1, 2) = (o2**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2) - END DO +END SUBROUTINE LeftVerticalEdgeBasisGradient_Quadrangle_ -END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ +!---------------------------------------------------------------------------- +! 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 - 1)) * dL1(ii, 1) * L2(ii, k2) + ans(ii, offset + k2 - 1, 2) = (mysign**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2) + END DO +END SUBROUTINE RightVerticalEdgeBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- ! HorizontalEdgeBasis_Quadrangle @@ -280,6 +375,7 @@ END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ maxP = MAX(pe3, pe4) nrow = SIZE(x) +ncol = 0 aint = SIZE(y) ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) @@ -287,67 +383,97 @@ END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) -CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans, nrow=nrow, ncol=ncol, pe3Orient=orient, pe4Orient=orient) +! 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 HorizontalEdgeBasis_Quadrangle2_( & - pe3, pe4, L1, L2, ans, nrow, ncol, pe3Orient, pe4Orient) - INTEGER(I4B), INTENT(IN) :: pe3 +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 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) !! point of evaluation REAL(DFP), INTENT(INOUT) :: ans(:, :) !! ans(SIZE(L1, 1), pe3 + pe4 - 2) INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns written to ans - INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient + INTEGER(I4B), INTENT(IN) :: orient !! orientaion of bottom and top edge + INTEGER(I4B), INTENT(IN) :: offset - INTEGER(I4B) :: k1, cnt, ii - REAL(DFP) :: o1, o2 + INTEGER(I4B) :: k1, ii + REAL(DFP) :: mysign - o1 = REAL(pe3Orient, kind=DFP) + mysign = REAL(orient, kind=DFP) - o2 = REAL(-pe4Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & - ! in master element - - nrow = SIZE(L1, 1) - ncol = pe3 + pe4 - 2 - cnt = pe3 - 1 + nrow = SIZE(L1, 1) !! number of points of evaluation + ncol = order - 1 !! these are internal dof on edge !! bottom edge - DO CONCURRENT(k1=2:pe3, ii=1:nrow) - ans(ii, k1 - 1) = (o1**k1) * L1(ii, k1) * L2(ii, 0) + 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:pe4, ii=1:nrow) - ans(ii, cnt + k1 - 1) = (o2**k1) * L1(ii, k1) * L2(ii, 1) + 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 HorizontalEdgeBasis_Quadrangle2_ +END SUBROUTINE TopHorizontalEdgeBasis_Quadrangle_ !---------------------------------------------------------------------------- -! HorizontalEdgeBasisGradient_Quadrangle +! BottomHorizontalEdgeBasisGradient_Quadrangle !---------------------------------------------------------------------------- -PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_( & - pe3, pe4, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, pe3Orient, pe4Orient) - INTEGER(I4B), INTENT(IN) :: pe3 +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 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) REAL(DFP), INTENT(INOUT) :: ans(:, :, :) @@ -355,37 +481,67 @@ PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_( & !! dim1 = SIZE(L1, 1) !! dim2 = pe3 + pe4 - 2 !! dim3 = 2 - INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient + INTEGER(I4B), INTENT(IN) :: orient !! orientation of bottom and top horizontal edge + INTEGER(I4B), INTENT(IN) :: offset !! internal variable - INTEGER(I4B) :: k1, cnt, ii - REAL(DFP) :: o1, o2 + INTEGER(I4B) :: k1, ii + REAL(DFP) :: mysign - o1 = REAL(pe3Orient, kind=DFP) + mysign = REAL(orient, kind=DFP) - o2 = REAL(-pe4Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & - ! in master element - - dim1 = SIZE(L1, 1) - dim2 = pe3 + pe4 - 2 - dim3 = 2 - cnt = pe3 - 1 + 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:pe3, ii=1:dim1) - ans(ii, k1 - 1, 1) = (o1**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0) - ans(ii, k1 - 1, 2) = (o1**(k1 - 1)) * L1(ii, k1) * dL2(ii, 0) + DO CONCURRENT(k1=2:order, ii=1:dim1) + ans(ii, offset + k1 - 1, 1) = (mysign**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0) + ans(ii, offset + k1 - 1, 2) = (mysign**(k1 - 1)) * 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:pe4, ii=1:dim1) - ans(ii, cnt + k1 - 1, 1) = (o2**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1) - ans(ii, cnt + k1 - 1, 2) = (o2**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1) + DO CONCURRENT(k1=2:order, ii=1:dim1) + ans(ii, offset + k1 - 1, 1) = (mysign**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1) + ans(ii, offset + k1 - 1, 2) = (mysign**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1) END DO -END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ +END SUBROUTINE TopHorizontalEdgeBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- ! CellBasis_Quadrangle @@ -410,7 +566,7 @@ END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ 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) + ncol=ncol, faceOrient=faceOrient, offset=0_I4B) END PROCEDURE CellBasis_Quadrangle_ @@ -419,7 +575,7 @@ END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ !---------------------------------------------------------------------------- PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & - faceOrient) + faceOrient, offset) INTEGER(I4B), INTENT(IN) :: pb !! order on bottom vertical edge (e3), it should be greater than 1 INTEGER(I4B), INTENT(IN) :: qb @@ -432,6 +588,8 @@ PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, 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 @@ -452,7 +610,7 @@ PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & END IF DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) - ans(ii, (q - 1) * (k1 - 2) + k2 - 1) = & + ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1) = & (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2) END DO @@ -462,8 +620,8 @@ END SUBROUTINE CellBasis_Quadrangle2_ ! CellBasisGradient_Quadrangle !---------------------------------------------------------------------------- -PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & - dL1, dL2, ans, dim1, dim2, dim3, faceOrient) +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 @@ -476,6 +634,9 @@ PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & !! 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 @@ -497,13 +658,11 @@ PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & END IF DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1) - - ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 1) = & + ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 1) = & (o1**(k1 - 1)) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) - ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 2) = & + ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 2) = & (o1**k1) * (o2**(k2 - 1)) * L1(ii, k1) * dL2(ii, k2) - END DO END SUBROUTINE CellBasisGradient_Quadrangle2_ @@ -598,22 +757,39 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ ncol = indx(2) -! Edge basis function -isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) +! Bottom Horizontal Edge +isok = (pe3 .GE. 2_I4B) IF (isok) THEN - CALL VerticalEdgeBasis_Quadrangle2_( & - qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans(:, ncol + 1:), nrow=indx(1), & - ncol=indx(2), qe1Orient=qe1Orient, qe2Orient=qe2Orient) + 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 -! Edge basis function -isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) +! Top Horizontal Edge +isok = (pe4 .GE. 2_I4B) IF (isok) THEN - CALL HorizontalEdgeBasis_Quadrangle2_( & - pe3=pe3, pe4=pe4, L1=L1, L2=L2, ans=ans(:, ncol + 1:), nrow=indx(1), & - ncol=indx(2), pe3Orient=pe3Orient, pe4Orient=pe4Orient) + 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 @@ -621,13 +797,12 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) IF (isok) THEN CALL CellBasis_Quadrangle2_( & - pb=pb, qb=qb, L1=L1, L2=L2, ans=ans(:, ncol + 1:), nrow=indx(1), & - ncol=indx(2), faceOrient=faceOrient) + 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_ !---------------------------------------------------------------------------- @@ -636,8 +811,9 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ 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) +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 !---------------------------------------------------------------------------- @@ -646,12 +822,10 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ 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) - +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_ !---------------------------------------------------------------------------- @@ -669,8 +843,9 @@ END SUBROUTINE CellBasisGradient_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) +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_ !---------------------------------------------------------------------------- @@ -685,11 +860,11 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ 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) - +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 !---------------------------------------------------------------------------- @@ -723,38 +898,54 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ dim2 = indx(2) -isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) - +! Bottom Horizontal Edge basis function +isok = (pe3 .GE. 2_I4B) IF (isok) THEN - CALL VerticalEdgeBasisGradient_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, & - L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), qe1Orient=qe1Orient, qe2Orient=qe2Orient) + 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 = (qe1 .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 -! Edge basis function -isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) +! Left Vertical Edge basis function +isok = (qe2 .GE. 2_I4B) IF (isok) THEN - CALL HorizontalEdgeBasisGradient_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, & - L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), pe3Orient=pe3Orient, pe4Orient=pe4Orient) + CALL LeftVerticalEdgeBasisGradient_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 ! 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(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), faceOrient=faceOrient) + 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 From e4e7d28e6f3a36da5098dc0e3967aa15b46caa8d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 18 Oct 2025 16:17:22 +0900 Subject: [PATCH 103/184] Updating TriangleInterpolationUtility Adding HierarchicalDOF method --- .../src/TriangleInterpolationUtility.F90 | 71 ++++++++++++------- ...lationUtility@HeirarchicalBasisMethods.F90 | 24 +++++++ 2 files changed, 68 insertions(+), 27 deletions(-) diff --git a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 index 7a2ab7be5..b67a0a302 100644 --- a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 @@ -69,6 +69,33 @@ MODULE TriangleInterpolationUtility PUBLIC :: GetTotalDOF_Triangle PUBLIC :: GetTotalInDOF_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 !---------------------------------------------------------------------------- @@ -1098,9 +1125,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 @@ -1138,9 +1164,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 @@ -1169,13 +1194,9 @@ END SUBROUTINE HeirarchicalBasis_Triangle2_ ! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle INTERFACE HeirarchicalBasis_Triangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, & - xij, refTriangle, & - edgeOrient1, & - edgeOrient2, & - edgeOrient3, & - faceOrient, & - ans, nrow, ncol) + MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_( & + order, pe1, pe2, pe3, xij, refTriangle, edgeOrient1, edgeOrient2, & + edgeOrient3, faceOrient, 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 @@ -1203,7 +1224,6 @@ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, & ! REAL(DFP) :: ans( & ! & 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_ @@ -1217,9 +1237,8 @@ END SUBROUTINE HeirarchicalBasis_Triangle3_ ! summary: Evaluate all Lagrange polynomial of order n at single points INTERFACE LagrangeEvalAll_Triangle - MODULE FUNCTION LagrangeEvalAll_Triangle1(order, x, xij, refTriangle, & - coeff, firstCall, & - basisType) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Triangle1( & + order, x, xij, refTriangle, coeff, firstCall, basisType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(2) @@ -1250,9 +1269,8 @@ END FUNCTION LagrangeEvalAll_Triangle1 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Triangle_ - MODULE SUBROUTINE LagrangeEvalAll_Triangle1_(order, x, xij, ans, tsize, & - refTriangle, coeff, & - firstCall, basisType) + 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) @@ -1291,9 +1309,9 @@ END SUBROUTINE LagrangeEvalAll_Triangle1_ ! summary: Evaluate all Lagrange polynomials of order n at several points INTERFACE LagrangeEvalAll_Triangle - MODULE FUNCTION LagrangeEvalAll_Triangle2(order, x, xij, refTriangle, & - coeff, firstCall, basisType, & - alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Triangle2( & + order, x, xij, refTriangle, coeff, firstCall, basisType, alpha, beta, & + lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1327,10 +1345,9 @@ END FUNCTION LagrangeEvalAll_Triangle2 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Triangle_ - MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, & - ncol, refTriangle, coeff, & - firstCall, basisType, alpha, & - beta, lambda) + 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(:, :) diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 index b516b00d9..331c293f6 100644 --- a/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 @@ -22,6 +22,30 @@ 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 !---------------------------------------------------------------------------- From abc230aad1f25880c81c362caf6a3c87529874bb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 19 Oct 2025 15:31:03 +0900 Subject: [PATCH 104/184] Formatting in TriangleInterpolation --- .../Triangle/src/TriangleInterpolationUtility.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 index b67a0a302..6f87d9441 100644 --- a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 @@ -1739,8 +1739,8 @@ END SUBROUTINE 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 @@ -1775,8 +1775,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 @@ -1809,9 +1809,9 @@ END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Triangle_ - MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle2_(order, pe1, pe2, & - pe3, xij, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, & - refTriangle, ans, tsize1, tsize2, tsize3) + 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 From 219000d8cf65ef80260f15b6eda427043808044e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 20 Oct 2025 08:14:02 +0900 Subject: [PATCH 105/184] Formatting LineInterpolationUtility --- src/submodules/Line/CMakeLists.txt | 8 +- .../LineInterpolationUtility@BasisMethods.F90 | 328 +++ ...terpolationUtility@HierarchicalMethods.F90 | 170 ++ ...erpolationUtility@InterpolationMethods.F90 | 550 +++++ ...neInterpolationUtility@LagrangeMethods.F90 | 452 ++++ .../src/LineInterpolationUtility@Methods.F90 | 1942 +---------------- ...InterpolationUtility@OrthogonalMethods.F90 | 156 ++ ...InterpolationUtility@QuadratureMethods.F90 | 279 +++ 8 files changed, 1943 insertions(+), 1942 deletions(-) create mode 100644 src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90 create mode 100644 src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90 create mode 100644 src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 create mode 100644 src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 create mode 100644 src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90 create mode 100644 src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 diff --git a/src/submodules/Line/CMakeLists.txt b/src/submodules/Line/CMakeLists.txt index f4b7e38ed..430382110 100644 --- a/src/submodules/Line/CMakeLists.txt +++ b/src/submodules/Line/CMakeLists.txt @@ -20,4 +20,10 @@ 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@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..7e88f4c44 --- /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, :)) + 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..8634f6221 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 @@ -0,0 +1,452 @@ +! 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 +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_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line2_()" +LOGICAL(LGT) :: isok +#endif + +LOGICAL(LGT) :: firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) +INTEGER(I4B) :: ii, orthopol0, aint, bint + +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) +firstCall0 = Input(default=.TRUE., option=firstCall) + +IF (PRESENT(coeff)) THEN + + IF (firstCall0) THEN + ! coeff = LagrangeCoeff_Line(& + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff, nrow=aint, ncol=bint) + END IF + + coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) + +ELSE + + ! coeff0 = LagrangeCoeff_Line(& + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & + nrow=aint, ncol=bint) + +END IF + +IF (orthopol0 .EQ. polyopt%monomial) THEN + + xx(:, 1) = 1.0_DFP + DO ii = 1, order + xx(:, ii + 1) = xx(:, ii) * x(1, :) + END DO + +ELSE + + CALL EvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, alpha=alpha, & + beta=beta, lambda=lambda, ans=xx, nrow=aint, ncol=bint) + +END IF + +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans, alpha=1.0_DFP, A=xx, B=coeff0) + +END PROCEDURE LagrangeEvalAll_Line2_ + +!---------------------------------------------------------------------------- +! 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_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "LagrangeGradientEvalAll_Line1_()" +LOGICAL(LGT) :: isok +#endif + +LOGICAL(LGT) :: firstCall0 +REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1), areal +INTEGER(I4B) :: ii, orthopol0, indx(2), jj + +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = 1 + +orthopol0 = Input(default=polyopt%Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) + +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=indx(1), ncol=indx(2)) + END IF + coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) + +ELSE + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff0, nrow=indx(1), ncol=indx(2)) +END IF + +SELECT CASE (orthopol0) +CASE (polyopt%Monomial) + +#ifdef DEBUG_VER + isok = dim2 .EQ. order + 1 + CALL AssertError1(isok, myName, modName, __LINE__, & + "size(xij, 2) is not same as order+1") +#endif + + DO ii = 0, order + indx(1) = MAX(ii - 1_I4B, 0_I4B) + areal = REAL(ii, kind=DFP) + DO jj = 1, dim1 + xx(jj, ii + 1) = areal * (x(1, jj)**(indx(1))) + END DO + END DO + +CASE DEFAULT + CALL GradientEvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=xx, nrow=dim1, ncol=dim2) + +END SELECT + +CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx, B=coeff0) +END PROCEDURE LagrangeGradientEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 index 4121672a4..b022b17ea 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 @@ -16,1955 +16,15 @@ ! SUBMODULE(LineInterpolationUtility) Methods -USE BaseType, ONLY: ipopt => TypeInterpolationOpt, & - qpopt => TypeQuadratureOpt, & - polyopt => TypePolynomialOpt, & - elmopt => TypeElemNameOpt - -USE GlobalData, ONLY: stderr -USE ErrorHandling, ONLY: Errormsg -USE Display_Method, ONLY: ToString - -USE StringUtility, ONLY: UpperCase - -USE MappingUtility, ONLY: FromBiunitLine2Segment_, & - FromBiunitLine2Segment, & - FromUnitLine2BiUnitLine, & - FromUnitLine2BiUnitLine_ - -USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, & - GradientEvalAllOrthopol_, & - EvalAllOrthopol, & - EvalAllOrthopol_ - -USE InputUtility, ONLY: Input - -USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde, & - LagrangeCoeff, & - LagrangeVandermonde_ - -USE LegendrePolynomialUtility, ONLY: LegendreQuadrature - -USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature - -USE JacobiPolynomialUtility, ONLY: JacobiQuadrature - -USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature - -USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat - -USE SortUtility, ONLY: HeapSort - -USE F95_BLAS, ONLY: GEMM - -#ifndef USE_BLAS95 -USE SwapUtility, ONLY: Swap -#else -USE F95_BLAS, ONLY: Swap -#endif - IMPLICIT NONE - -#ifdef DEBUG_VER -CHARACTER(*), PARAMETER :: modName = "LineInterpolationUtility@Methods.F90" -#endif - CONTAINS !---------------------------------------------------------------------------- -! RefElemDomain_Line +! RefElemDomain_Line !---------------------------------------------------------------------------- MODULE PROCEDURE RefElemDomain_Line ans = "BIUNIT" END PROCEDURE RefElemDomain_Line -!---------------------------------------------------------------------------- -! 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 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 -IF (ans .LT. 0_I4B) ans = 0_I4B -END PROCEDURE GetTotalInDOF_Line - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line1 -INTEGER(I4B) :: tsize - -IF (order .LE. 1_I4B) 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 - -IF (order .LE. 1_I4B) THEN - ALLOCATE (ans(0, 0)) - RETURN -END IF - -IF (PRESENT(xij)) 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_ -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 - -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line1_()", & - file=__FILE__, line=__LINE__, unitno=stderr) -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, :)) - 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 - CHARACTER(:), ALLOCATABLE :: msg - - SELECT CASE (ipType) - CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto) - isok = PRESENT(alpha) .AND. PRESENT(beta) - IF (.NOT. isok) THEN - msg = "alpha and beta should be present for ipType=GaussJacobi" - - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - - CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) - isok = PRESENT(lambda) - IF (.NOT. isok) THEN - msg = "lambda should be present for ipType=GaussUltraSpherical" - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - END SELECT - -#endif - -END SUBROUTINE handle_error - -END PROCEDURE InterpolationPoint_Line1_ - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line2_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Line2_ -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 - -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) -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 - CHARACTER(:), ALLOCATABLE :: msg - - SELECT CASE (ipType) - CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto) - isok = PRESENT(alpha) .AND. PRESENT(beta) - IF (.NOT. isok) THEN - msg = "alpha and beta should be present for ipType=GaussJacobi" - - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - - CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) - isok = PRESENT(lambda) - IF (.NOT. isok) THEN - msg = "lambda should be present for ipType=GaussUltraSpherical" - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - END SELECT - -#endif - -END SUBROUTINE handle_error - -END PROCEDURE InterpolationPoint_Line2_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line1 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Line1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Line1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line1_ -REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info, 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:nrow, 1:ncol) = TRANSPOSE(coeff(1:nrow, 1:ncol)) - 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) - - ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff0(1:nrow, 1: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_ -#ifdef DEBUG_VER -CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line2_()" -LOGICAL(LGT) :: isok -#endif - -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0, aint, bint - -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) -firstCall0 = Input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - ! coeff = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff, nrow=aint, ncol=bint) - END IF - - coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) - -ELSE - - ! coeff0 = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=aint, ncol=bint) - -END IF - -IF (orthopol0 .EQ. polyopt%monomial) THEN - - xx(:, 1) = 1.0_DFP - DO ii = 1, order - xx(:, ii + 1) = xx(:, ii) * x(1, :) - END DO - -ELSE - - ! xx = EvalAllOrthopol( - CALL EvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, alpha=alpha, & - beta=beta, lambda=lambda, ans=xx, nrow=aint, ncol=bint) - -END IF - -! ans = MATMUL(xx, coeff0) -CALL GEMM(C=ans, alpha=1.0_DFP, A=xx, B=coeff0) - -END PROCEDURE LagrangeEvalAll_Line2_ - -!---------------------------------------------------------------------------- -! EvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line1 -INTEGER(I4B) :: 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 - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (order + 1 .GT. SIZE(temp, 2)) THEN - CALL Errormsg( & - msg="order+1 is greater than number of col in temp", & - routine="BasisEvalAll_Line1_", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -#endif - - x1(1) = x - CALL EvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, alpha=alpha, & - beta=beta, lambda=lambda, ans=temp, nrow=nrow, ncol=ncol) - - ans(1:tsize) = temp(1, 1:tsize) - -END SELECT - -END PROCEDURE BasisEvalAll_Line1_ - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line1 -INTEGER(I4B) :: tsize -CALL BasisGradientEvalAll_Line1_(order=order, x=x, refLine=refLine, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & - tsize=tsize) -END PROCEDURE BasisGradientEvalAll_Line1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line1_ -INTEGER(I4B) :: ii, basisType0 -CHARACTER(:), ALLOCATABLE :: astr -REAL(DFP) :: areal, breal, x1(1), temp(1, order + 1) - -astr = UpperCase(refline) - -tsize = order + 1 - -#ifdef DEBUG_VER - -IF (astr .EQ. "UNIT") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - -#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 - - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - - 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_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line2 -INTEGER(I4B) :: nrow, ncol -CALL BasisGradientEvalAll_Line2_(order=order, x=x, ans=ans, nrow=nrow, & - ncol=ncol, refLine=refLine, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) -END PROCEDURE BasisGradientEvalAll_Line2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line2_ -INTEGER(I4B) :: ii, basisType0, jj -REAL(DFP) :: areal, breal -CHARACTER(:), ALLOCATABLE :: astr - -nrow = SIZE(x) -ncol = 1 + order - -astr = UpperCase(refLine) - -#ifdef DEBUG_VER - -IF (astr .EQ. "UNIT") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisGradientEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - -#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 - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisGradientEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisGradientEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - -#endif - - ! ans = GradientEvalAllOrthopol(& - CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) - -END SELECT - -END PROCEDURE BasisGradientEvalAll_Line2_ - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line2 -INTEGER(I4B) :: nrow, ncol -CALL BasisEvalAll_Line2_(order=order, x=x, ans=ans, nrow=nrow, ncol=ncol, & - refline=refline, basistype=basistype, & - alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE BasisEvalAll_Line2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line2_ -#ifdef DEBUG_VER -CHARACTER(1) :: astr - -#endif - -INTEGER(I4B) :: ii, basisType0 - -nrow = SIZE(x) -ncol = order + 1 - -#ifdef DEBUG_VER - -astr = UpperCase(refline(1:1)) - -IF (astr .EQ. "U") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - -#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 - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - 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_ - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line1 -INTEGER(I4B) :: nips(1), nrow, ncol - -nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1 -END IF - -nrow = nrow + 1 -ncol = nips(1) - -ALLOCATE (ans(nrow, ncol)) - -CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & - xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) - -END PROCEDURE QuadraturePoint_Line1 - -!---------------------------------------------------------------------------- -! 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 - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1 -END IF - -nrow = nrow + 1 -ncol = nips(1) - -ALLOCATE (ans(nrow, ncol)) - -CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & - xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) - -END PROCEDURE QuadraturePoint_Line3 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line4 -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 -LOGICAL(LGT) :: isok -#endif - -INTEGER(I4B) :: np, nsd, ii, jj -REAL(DFP) :: areal -LOGICAL(LGT) :: changeLayout - -nrow = 0 -ncol = 0 - -#ifdef DEBUG_VER - -SELECT CASE (quadType) -CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto, & - ipopt%GaussJacobiRadauLeft, ipopt%GaussJacobiRadauRight) - - isok = PRESENT(alpha) .AND. PRESENT(beta) - - IF (.NOT. isok) THEN - CALL ErrorMsg(routine="QuadraturePoint_Line3", & - msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto, & - ipopt%GaussUltraSphericalRadauLeft, ipopt%GaussUltraSphericalRadauRight) - - isok = PRESENT(lambda) - - IF (.NOT. isok) THEN - CALL ErrorMsg(routine="QuadraturePoint_Line3", & - msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -END SELECT - -#endif - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 1 -END IF - -np = nips(1) -nrow = nsd + 1 -ncol = nips(1) - -changeLayout = .FALSE. -IF (layout(1:1) .EQ. "V") 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) - -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="QuadraturePoint_Line3", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -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 - - RETURN -END IF - -END PROCEDURE QuadraturePoint_Line1_ - -!---------------------------------------------------------------------------- -! 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=polyopt%Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - 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 (polyopt%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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Line1_ -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1), areal -INTEGER(I4B) :: ii, orthopol0, indx(2), jj - -dim1 = SIZE(x, 2) -dim2 = SIZE(xij, 2) -dim3 = 1 -!! ans(SIZE(x, 2), SIZE(xij, 2), 1) - -orthopol0 = input(default=polyopt%Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - - ! coeff = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff, & - nrow=indx(1), ncol=indx(2)) - - END IF - - coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) - -ELSE - - ! coeff0 = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & - nrow=indx(1), ncol=indx(2)) -END IF - -SELECT CASE (orthopol0) -CASE (polyopt%Monomial) - -#ifdef DEBUG_VER - - IF (dim2 .NE. order + 1) THEN - CALL Errormsg(msg="size(xij, 2) is not same as order+1", & - routine="LagrangeGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -#endif - - DO ii = 0, order - indx(1) = MAX(ii - 1_I4B, 0_I4B) - areal = REAL(ii, kind=DFP) - DO jj = 1, dim1 - xx(jj, ii + 1) = areal * (x(1, jj)**(indx(1))) - END DO - END DO - -CASE DEFAULT - - ! xx(1:dim1, 1:dim2) = GradientEvalAllOrthopol(n=order, x=x(1, :), & - CALL GradientEvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=xx, nrow=dim1, ncol=dim2) - -END SELECT - -! ans(:, :, 1) = MATMUL(xx, coeff0) -CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx, B=coeff0) - -END PROCEDURE LagrangeGradientEvalAll_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line1 -INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Line1_(order=order, xij=xij, refLine=refLine, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Line1 - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line1_ -INTEGER(I4B), PARAMETER :: orient = 1 -CALL HeirarchicalBasis_Line2_(order=order, xij=xij, refLine=refLine, & - orient=orient, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line2_ -CHARACTER(1) :: astr -REAL(DFP) :: temp(SIZE(xij, 2)), o1 -INTEGER(I4B) :: ii, k - -o1 = REAL(orient, kind=DFP) -astr = UpperCase(refLine(1:1)) - -! nrow = SIZE(xij, 2) -! ncol = order + 1 - -SELECT CASE (astr) -CASE ("U") - CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=nrow) - CALL EvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, ans=ans, & - nrow=nrow, ncol=ncol) - -CASE ("B") - CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=polyopt%Lobatto, & - ans=ans, nrow=nrow, ncol=ncol) - -CASE DEFAULT - nrow = 0 - ncol = 0 -END SELECT - -DO CONCURRENT(k=2:order, ii=1:nrow) - ans(ii, k + 1) = (o1**k) * ans(ii, k + 1) -END DO - -END PROCEDURE HeirarchicalBasis_Line2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalGradientBasis_Line1 -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_ - -!---------------------------------------------------------------------------- -! 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_ -LOGICAL(LGT) :: isok, abool -#ifdef DEBUG_VER -#endif - -CHARACTER(1) :: astr -REAL(DFP) :: x(SIZE(xij, 2)) - -nrow = SIZE(xij, 2) -ncol = order + 1 - -#ifdef DEBUG_VER - -ans(1:nrow, 1:ncol) = 0.0_DFP - -isok = basisType .EQ. polyopt%Jacobi - -IF (isok) THEN - abool = (.NOT. PRESENT(alpha)) .OR. (.NOT. PRESENT(beta)) - - IF (abool) THEN - CALL Errormsg(routine="OrthogonalBasis_Line1()", & - msg="alpha and beta should be present for basisType=Jacobi", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -END IF - -isok = basisType .EQ. polyopt%Ultraspherical -IF (isok) THEN - - abool = .NOT. PRESENT(lambda) - - IF (abool) THEN - CALL Errormsg(routine="OrthogonalBasis_Line1()", file=__FILE__, & - msg="lambda should be present for basisType=Ultraspherical", & - line=__LINE__, unitno=stderr) - RETURN - END IF - -END IF - -#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) - -CASE DEFAULT - - ans(1:nrow, 1:ncol) = 0.0_DFP - CALL Errormsg(msg="No case found for refLine.", & - routine="OrthogonalBasis_Line1()", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - -END SELECT - -END PROCEDURE OrthogonalBasis_Line1_ - -!---------------------------------------------------------------------------- -! 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_ -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) - -CASE DEFAULT - - ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP - CALL Errormsg(msg="No case found for refline.", & - routine=" OrthogonalBasisGradient_Line1_", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - -END SELECT -END PROCEDURE OrthogonalBasisGradient_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#include "../../include/errors.F90" - 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..a2a42db6b --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 @@ -0,0 +1,279 @@ +! 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 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 From 831ebf372af1c96e9c815d5f96aa6eea331d0581 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 22 Oct 2025 20:20:32 +0900 Subject: [PATCH 106/184] Updating LagrangePolynomialUtility Adding Vandermonde matrix. --- .../src/LagrangePolynomialUtility.F90 | 34 ++++++++++++++++--- .../src/LagrangePolynomialUtility@Methods.F90 | 17 +++++++--- 2 files changed, 42 insertions(+), 9 deletions(-) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index dde8431a2..1398c5d4d 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -153,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 @@ -167,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 diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index 313f99916..c49b17cb7 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -249,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) @@ -280,8 +290,7 @@ END SELECT -IF (ALLOCATED(degree)) DEALLOCATE (degree) -END PROCEDURE LagrangeVandermonde_ +END PROCEDURE LagrangeVandermonde2_ !---------------------------------------------------------------------------- ! EquidistancePoint From ef2205940ec7d17a5607245dc85aa1e93943569f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 22 Oct 2025 21:03:42 +0900 Subject: [PATCH 107/184] Updating TriangleInterpolationUtility --- .../src/TriangleInterpolationUtility.F90 | 116 ++++++- ...erpolationUtility@LagrangeBasisMethods.F90 | 150 +++++++-- .../TriangleInterpolationUtility@Methods.F90 | 291 +++++++++--------- ...InterpolationUtility@QuadratureMethods.F90 | 144 +++++---- 4 files changed, 450 insertions(+), 251 deletions(-) diff --git a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 index 6f87d9441..fbe3299d9 100644 --- a/src/modules/Triangle/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 @@ -674,8 +674,7 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle2_(order, i, v, 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 + ! ans(SIZE(v, 1)) ! coefficients of ith Lagrange polynomial INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE LagrangeCoeff_Triangle2_ END INTERFACE LagrangeCoeff_Triangle_ @@ -718,8 +717,7 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle3_(order, i, v, ipiv, ans, tsize) INTEGER(I4B), INTENT(IN) :: ipiv(:) !! inverse pivoting mapping, compes from LU decomposition REAL(DFP), INTENT(INOUT) :: ans(:) - !! ans(SIZE(v, 1)) - !! coefficients + !! ans(SIZE(v, 1)) ! coefficients INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE LagrangeCoeff_Triangle3_ END INTERFACE LagrangeCoeff_Triangle_ @@ -740,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 @@ -767,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 @@ -780,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 !---------------------------------------------------------------------------- @@ -1380,6 +1423,49 @@ MODULE SUBROUTINE LagrangeEvalAll_Triangle2_( & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -1574,7 +1660,7 @@ END SUBROUTINE 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) diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index 8c5c84b4c..8fb1b6a62 100644 --- a/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -16,13 +16,10 @@ 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 - USE F95_BLAS, ONLY: GEMM - USE BaseType, ONLY: polyopt => TypePolynomialOpt, elemopt => TypeElemNameOpt IMPLICIT NONE @@ -173,7 +170,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Triangle4_ - SELECT CASE (basisType) CASE (polyopt%Monomial) @@ -188,25 +184,65 @@ CASE (polyopt%Hierarchical) - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=xij, refTriangle=refTriangle, & - ans=ans, nrow=nrow, ncol=ncol) + 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) +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 !---------------------------------------------------------------------------- @@ -285,13 +321,12 @@ !---------------------------------------------------------------------------- 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) +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 !---------------------------------------------------------------------------- @@ -313,8 +348,9 @@ IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff, nrow=aint, ncol=bint) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff, nrow=aint, ncol=bint) END IF @@ -322,8 +358,9 @@ ELSE - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff0, nrow=aint, ncol=bint) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff0, nrow=aint, ncol=bint) END IF @@ -340,8 +377,9 @@ CASE (polyopt%Hierarchical) - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=x, refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint) + 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) @@ -386,15 +424,17 @@ 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)) + 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)) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff0, nrow=s(1), ncol=s(2)) END IF SELECT CASE (basisType0) @@ -416,15 +456,16 @@ 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)) + 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)) + CALL OrthogonalBasisGradient_Triangle_( & + order=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), & + tsize2=s(2), tsize3=s(3)) END SELECT @@ -435,6 +476,51 @@ 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 index 31df2c156..e5119a32b 100644 --- a/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 @@ -16,27 +16,18 @@ SUBMODULE(TriangleInterpolationUtility) Methods USE BaseType, ONLY: ipopt => TypeInterpolationOpt - USE StringUtility, ONLY: UpperCase - -USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line, & - EquidistanceInPoint_Line_, & - LagrangeInDOF_Line, & - InterpolationPoint_Line_ - USE MappingUtility, ONLY: FromUnitTriangle2Triangle_ - -USE ErrorHandling, ONLY: Errormsg - USE RecursiveNodesUtility, ONLY: RecursiveNode2D_ - -USE IntegerUtility, ONLY: Size - USE Display_Method, ONLY: ToString - -USE GlobalData, ONLY: stderr +USE IntegerUtility, ONLY: NumberOfTuples => SIZE +USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line_, & + InterpolationPoint_Line_ IMPLICIT NONE + +CHARACTER(*), PARAMETER :: modName = "TriangleInterpolationUtility%Methods" + CONTAINS !---------------------------------------------------------------------------- @@ -60,11 +51,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RefElemDomain_Triangle +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "RefElemDomain_Triangle()" +#endif + CHARACTER(2) :: bc -CHARACTER(3) :: bi +CHARACTER(1) :: bi bc = UpperCase(baseContinuity(1:2)) -bi = UpperCase(baseInterpol(1:3)) +bi = UpperCase(baseInterpol(1:1)) SELECT CASE (bc) @@ -72,31 +67,31 @@ SELECT CASE (bi) - !! Lagrange - CASE ("LAG", "SER", "HER") + !! Lagrange ! Serendipity + CASE ("L", "S") ans = "UNIT" - CASE ("HIE", "HEI") + !! Hierarchical + CASE ("H") ans = "BIUNIT" - CASE ("ORT") + !! Orthognal + CASE ("O") ans = "BIUNIT" +#ifdef DEBUG_VER CASE DEFAULT - - CALL Errormsg( & - msg="No case found for given baseInterpol="//TRIM(baseInterpol), & - routine="RefElemDomain_Triangle()", file=__FILE__, line=__LINE__, & - unitno=stderr) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "No case found for given baseInterpol="//TRIM(baseInterpol)) +#endif END SELECT +#ifdef DEBUG_VER CASE DEFAULT - - CALL Errormsg( & - msg="No case found for given baseContinuity="//TRIM(baseContinuity), & - file=__FILE__, line=__LINE__, routine="RefElemDomain_Triangle()", & - unitno=stderr) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "No case found for given baseContinuity="//TRIM(baseContinuity)) +#endif END SELECT @@ -107,28 +102,29 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FacetConnectivity_Triangle -CHARACTER(1) :: bi -LOGICAL(LGT) :: isok - -isok = PRESENT(baseInterpol) -IF (isok) THEN - bi = UpperCase(baseInterpol(1:1)) -ELSE - bi = "L" -END IF - -SELECT CASE (bi) -CASE ("H", "O") - ans(1:2, 1) = [1, 2] - ans(1:2, 2) = [1, 3] - ans(1:2, 3) = [2, 3] +! CHARACTER(1) :: bi +! LOGICAL(LGT) :: isok -CASE DEFAULT - ans(1:2, 1) = [1, 2] - ans(1:2, 2) = [2, 3] - ans(1:2, 3) = [3, 1] +ans(1:2, 1) = [1, 2] +ans(1:2, 2) = [2, 3] +ans(1:2, 3) = [3, 1] -END SELECT +! 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 !---------------------------------------------------------------------------- @@ -137,19 +133,17 @@ MODULE PROCEDURE EquidistancePoint_Triangle INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2_I4B -END IF +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 !---------------------------------------------------------------------------- @@ -159,10 +153,13 @@ 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 -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) + +IF (isok) THEN nrow = SIZE(xij, 1) x(1:nrow, 1:3) = xij(1:nrow, 1:3) ELSE @@ -173,47 +170,35 @@ END IF ncol = LagrangeDOF_Triangle(order=order) -! ALLOCATE (ans(nrow, n)) -! ans = 0.0_DFP !! points on vertex ans(1:nrow, 1:3) = x(1:nrow, 1:3) !! points on edge -! ne = LagrangeInDOF_Line(order=order) i2 = 3 -IF (order .GT. 1_I4B) THEN +isok = order .GT. 1_I4B +IF (isok) THEN i1 = i2 + 1 ! i1 = i2 + 1; i2 = i1 + ne - 1 - ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & - ! order=order, & - ! xij=x(1:nrow, [1, 2])) CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [1, 2]), & ans=ans(:, i1:), nrow=aint, ncol=bint) i1 = i1 + bint - ! i1 = i2 + 1; i2 = i1 + ne - 1 - ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & - ! order=order, & - ! xij=x(1:nrow, [2, 3])) CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [2, 3]), & ans=ans(:, i1:), nrow=aint, ncol=bint) i1 = i1 + bint - ! i1 = i2 + 1; i2 = i1 + ne - 1 - ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & - ! order=order, & - ! xij=x(1:nrow, [3, 1])) CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [3, 1]), & ans=ans(:, i1:), nrow=aint, ncol=bint) i2 = i1 + bint - 1 - END IF -IF (order .LE. 2_I4B) RETURN +isok = order .LE. 2_I4B +IF (isok) RETURN !! points on face -IF (order .EQ. 3_I4B) THEN +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 @@ -250,11 +235,8 @@ xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow) i1 = i2 + 1 -! ans(1:nrow, i1:) = EquidistancePoint_Triangle(order=order - 3, & -! xij=xin(1:nrow, 1:3)) CALL EquidistancePoint_Triangle_(order=order - 3, xij=xin(1:nrow, 1:3), & ans=ans(1:nrow, i1:), nrow=aint, ncol=bint) - END PROCEDURE EquidistancePoint_Triangle_ !---------------------------------------------------------------------------- @@ -263,23 +245,20 @@ MODULE PROCEDURE EquidistanceInPoint_Triangle INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (order .LT. 3_I4B) THEN +isok = order .LT. 3_I4B +IF (isok) THEN ALLOCATE (ans(0, 0)) RETURN END IF -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2_I4B -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 !---------------------------------------------------------------------------- @@ -289,28 +268,30 @@ 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 -IF (order .LT. 3_I4B) RETURN + +isok = order .LT. 3_I4B +IF (isok) RETURN x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP -IF (PRESENT(xij)) THEN +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) -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 = LagrangeInDOF_Triangle(order=order) -! ALLOCATE (ans(nrow, n)) -! ans = 0.0_DFP !! points on face -IF (order .EQ. 3_I4B) THEN +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 @@ -356,11 +337,15 @@ MODULE PROCEDURE BlythPozrikidis_Triangle INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +isok = PRESENT(xij) ncol = LagrangeDOF_Triangle(order=order) -nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +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) +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 !---------------------------------------------------------------------------- @@ -368,8 +353,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE BlythPozrikidis_Triangle_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle_()" +#endif + INTEGER(I4B), PARAMETER :: max_order = 30 -CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle()" REAL(DFP), PARAMETER :: x(2) = [0.0_DFP, 1.0_DFP] REAL(DFP) :: v(max_order + 1), xi(max_order + 1, max_order + 1), & @@ -407,17 +395,19 @@ 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) + 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 ErrorMsg(msg="layout=VEFC is allowed, found layout is "//TRIM(layout), & - file=__FILE__, routine=myname, line=__LINE__, unitno=stderr) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "layout=VEFC is allowed, found layout is "//TRIM(layout)) +#endif END SELECT @@ -430,7 +420,7 @@ MODULE PROCEDURE Isaac_Triangle INTEGER(I4B) :: nrow, ncol -ncol = SIZE(n=order, d=2) +ncol = NumberOfTuples(n=order, d=2) nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) ALLOCATE (ans(nrow, ncol)) @@ -446,8 +436,12 @@ !---------------------------------------------------------------------------- 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) @@ -462,7 +456,8 @@ alpha=alpha, beta=beta, lambda=lambda, ans=temp, & nrow=nrow, ncol=ncol) -IF (PRESENT(xij)) nrow = SIZE(xij, 1) +isok = PRESENT(xij) +IF (isok) nrow = SIZE(xij, 1) !! convert from rPoints to xi and eta cnt = 0 @@ -477,13 +472,14 @@ END DO END DO -IF (layout .EQ. "VEFC") THEN - ! CALL Reallocate(temp, 2, N) +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)) + CALL FromUnitTriangle2Triangle_( & + xin=temp(:, 1:ncol), ans=ans, nrow=nrow, ncol=ncol, x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3)) RETURN END IF @@ -491,9 +487,10 @@ RETURN END IF -CALL ErrorMsg(file=__FILE__, routine=myname, line=__LINE__, unitno=stderr, & - msg="Only layout=VEFC is allowed, found layout is "//layout) - +#ifdef DEBUG_VER +CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "Only layout=VEFC is allowed, found layout is "//layout) +#endif END PROCEDURE Isaac_Triangle_ !---------------------------------------------------------------------------- @@ -501,6 +498,11 @@ !---------------------------------------------------------------------------- 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 @@ -547,7 +549,8 @@ !! internal nodes END DO -IF (llr .EQ. 2_I4B) THEN +isok = llr .EQ. 2_I4B +IF (isok) THEN !! a internal point cnt = cnt + 1 ll = llt + 1 @@ -556,13 +559,12 @@ temp(2, cnt) = eta(ii, jj) END IF -IF (cnt .NE. N) THEN - CALL ErrorMsg(file=__FILE__, routine="IJ2VEFC_Triangle()", & - line=__LINE__, unitno=stderr, & - msg="cnt="//ToString(cnt)//" not equal to total DOF, N=" & - //ToString(N)) - RETURN -END IF +#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 @@ -585,7 +587,7 @@ CASE (ipopt%IsaacLegendre, ipopt%IsaacChebyshev, & ipopt%GaussLegendreLobatto, ipopt%GaussChebyshevLobatto) - ncol = SIZE(n=order, d=2) + ncol = NumberOfTuples(n=order, d=2) END SELECT @@ -602,7 +604,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Triangle_ +#ifdef DEBUG_VER CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle_()" +#endif SELECT CASE (ipType) CASE (ipopt%Equidistance) @@ -610,30 +614,35 @@ 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) + 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) + 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) + 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) + CALL Isaac_Triangle_( & + order=order, ipType=ipopt%GaussChebyshevLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) CASE (ipopt%Feket, ipopt%Hesthaven, ipopt%ChenBabuska) - CALL ErrorMsg(msg="Feket, Hesthaven, ChenBabuska nodes not available", & - file=__FILE__, routine=myname, line=__LINE__, unitno=stderr) + +#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", & @@ -647,4 +656,6 @@ ! !---------------------------------------------------------------------------- +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 4e28ef681..42816de22 100644 --- a/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -15,11 +15,24 @@ ! along with this program. If not, see SUBMODULE(TriangleInterpolationUtility) QuadratureMethods -USE BaseMethod 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 !---------------------------------------------------------------------------- @@ -27,9 +40,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadratureNumber_Triangle +LOGICAL(LGT) :: isok + ans = QuadratureNumberTriangleSolin(order=order) -IF (ans .LE. 0) THEN +isok = ans .LE. 0 +IF (isok) THEN ans = 1_I4B + INT(order / 2, kind=I4B) ans = ans * (ans + 1) END IF @@ -41,25 +57,24 @@ 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 -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2_I4B) -ELSE - nrow = 2_I4B -END IF +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) +CALL TensorQuadraturePoint_Triangle2_( & + nipsx=nipsx, nipsy=nipsy, quadType=quadType, refTriangle=refTriangle, & + xij=xij, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle1 !---------------------------------------------------------------------------- @@ -73,9 +88,9 @@ 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) +CALL TensorQuadraturePoint_Triangle2_( & + nipsx=nipsx, nipsy=nipsy, quadType=quadType, refTriangle=refTriangle, & + xij=xij, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle1_ !---------------------------------------------------------------------------- @@ -84,21 +99,20 @@ MODULE PROCEDURE TensorQuadraturePoint_Triangle2 INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2_I4B) -ELSE - nrow = 2_I4B -END IF +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) +CALL TensorQuadraturePoint_Triangle2_( & + nipsx=nipsx, nipsy=nipsy, quadType=quadType, refTriangle=refTriangle, & + xij=xij, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle2 !---------------------------------------------------------------------------- @@ -110,24 +124,22 @@ REAL(DFP), ALLOCATABLE :: temp(:, :) REAL(DFP) :: areal REAL(DFP), PARAMETER :: oneby8 = 1.0_DFP / 8.0_DFP - +LOGICAL(LGT) :: isok CHARACTER(1) :: astr -IF (PRESENT(xij)) THEN - nsd = MAX(SIZE(xij, 1), 2_I4B) -ELSE - nsd = 2_I4B -END IF +nsd = 2_I4B +isok = PRESENT(xij) +IF (isok) nsd = MAX(SIZE(xij, 1), 2_I4B) nrow = nsd + 1_I4B ncol = nipsx(1) * nipsy(1) -! ALLOCATE (temp(nrow, ncol)) - -CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & - quadType1=GaussLegendreLobatto, quadType2=GaussJacobiRadauLeft, & - refQuadrangle="BIUNIT", alpha2=1.0_DFP, beta2=0.0_DFP, ans=ans, & - nrow=ii, ncol=jj) +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, & @@ -138,8 +150,9 @@ 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) + 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) @@ -163,9 +176,7 @@ END DO RETURN - END IF - END PROCEDURE TensorQuadraturePoint_Triangle2_ !---------------------------------------------------------------------------- @@ -185,8 +196,9 @@ ALLOCATE (ans(nrow, ncol)) -CALL QuadraturePoint_Triangle1_(order=order, quadType=quadType, & - refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +CALL QuadraturePoint_Triangle1_( & + order=order, quadType=quadType, refTriangle=refTriangle, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Triangle1 !---------------------------------------------------------------------------- @@ -199,19 +211,19 @@ 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) + 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) - +CALL QuadraturePoint_Triangle2_( & + nips=nips, quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Triangle1_ !---------------------------------------------------------------------------- -! QuadraturePoint_Triangle2 +! QuadraturePoint_Triangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Triangle2 @@ -227,9 +239,9 @@ ALLOCATE (ans(nrow, ncol)) -CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, & - refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) - +CALL QuadraturePoint_Triangle2_( & + nips=nips, quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Triangle2 !---------------------------------------------------------------------------- @@ -237,8 +249,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Triangle2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "QuadraturePoint_Triangle2_()" +#endif + INTEGER(I4B) :: nsd, ii, jj -LOGICAL(LGT) :: abool +LOGICAL(LGT) :: isok REAL(DFP) :: areal CHARACTER(1) :: astr @@ -246,25 +262,24 @@ ncol = 0 ii = QuadratureNumberTriangleSolin(order=20) -abool = nips(1) .GT. ii -IF (abool) THEN - CALL Errormsg(msg="This routine should be called for economical & - & quadrature points only, otherwise call QuadraturePoint_Triangle1()", & - routine="QuadraturePoint_Triangle2()", & - file=__FILE__, line=__LINE__, unitNo=stdout) - RETURN -END IF + +#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 -abool = PRESENT(xij) -IF (abool) nsd = SIZE(xij, 1) +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 (abool) THEN +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) @@ -280,9 +295,9 @@ END IF astr = UpperCase(reftriangle(1:1)) -abool = astr == "B" +isok = astr == "B" -IF (abool) THEN +IF (isok) THEN CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), ans=ans, & from="U", to="B", nrow=ii, ncol=jj) @@ -294,11 +309,12 @@ RETURN END IF - END PROCEDURE QuadraturePoint_Triangle2_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +#include "../../include/errors.F90" + END SUBMODULE QuadratureMethods From 7aaef3c7de2dff91d632e8e7561cd0a9c549cfd6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 27 Oct 2025 12:06:53 +0900 Subject: [PATCH 108/184] Updating LineInterpolationUtility --- src/modules/Line/src/LineInterpolationUtility.F90 | 5 +++-- .../Line/src/LineInterpolationUtility@LagrangeMethods.F90 | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index 3ee296382..8d40b3ed2 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -901,8 +901,9 @@ END FUNCTION LagrangeEvalAll_Line2 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Line_ - MODULE SUBROUTINE LagrangeEvalAll_Line2_(order, x, xij, ans, nrow, ncol, & - coeff, firstCall, basisType, alpha, beta, lambda) + 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(:, :) diff --git a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 index 8634f6221..23f7a3bbb 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 @@ -17,7 +17,7 @@ SUBMODULE(LineInterpolationUtility) LagrangeMethods USE BaseType, ONLY: polyopt => TypePolynomialOpt, elmopt => TypeElemNameOpt -USE Display_Method, ONLY: ToString +USE Display_Method, ONLY: ToString, Display USE InputUtility, ONLY: Input USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat USE F95_BLAS, ONLY: GEMM @@ -333,7 +333,6 @@ IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - ! coeff = LagrangeCoeff_Line(& CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & alpha=alpha, beta=beta, lambda=lambda, & ans=coeff, nrow=aint, ncol=bint) @@ -365,7 +364,8 @@ END IF ! ans = MATMUL(xx, coeff0) -CALL GEMM(C=ans, alpha=1.0_DFP, A=xx, B=coeff0) +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx(1:nrow, 1:ncol), & + B=coeff0(1:ncol, 1:ncol)) END PROCEDURE LagrangeEvalAll_Line2_ From 5992e87575ec68ad97643c2966a6e81a466959e1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 27 Oct 2025 15:19:10 +0900 Subject: [PATCH 109/184] Updating LineInterpolationUtility --- .../Line/src/LineInterpolationUtility.F90 | 85 +++++++++++++++++-- ...neInterpolationUtility@LagrangeMethods.F90 | 76 +++++++++-------- .../OrthogonalPolynomialUtility@Methods.F90 | 13 +++ 3 files changed, 131 insertions(+), 43 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index 8d40b3ed2..367a6a770 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -817,9 +817,14 @@ END FUNCTION LagrangeEvalAll_Line1 ! LagrangeEvalAll_Line_ !---------------------------------------------------------------------------- -INTERFACE LagrangeEvalAll_Line_ - MODULE SUBROUTINE LagrangeEvalAll_Line1_(order, x, xij, coeff, firstCall, & - basisType, alpha, beta, lambda, ans, tsize) +!> 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 @@ -846,6 +851,10 @@ MODULE SUBROUTINE LagrangeEvalAll_Line1_(order, x, xij, coeff, firstCall, & !! 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_ !---------------------------------------------------------------------------- @@ -857,8 +866,9 @@ END SUBROUTINE LagrangeEvalAll_Line1_ ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeEvalAll_Line - MODULE FUNCTION LagrangeEvalAll_Line2(order, x, xij, coeff, firstCall, & - basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Line2( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -897,9 +907,13 @@ 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, & @@ -940,6 +954,65 @@ MODULE SUBROUTINE LagrangeEvalAll_Line2_( & 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 index 23f7a3bbb..834722597 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 @@ -309,14 +309,40 @@ !---------------------------------------------------------------------------- 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_Line2_()" +CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line3_()" LOGICAL(LGT) :: isok #endif -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0, aint, bint +INTEGER(I4B) :: orthopol0, xx_i, xx_j, coeff_i, coeff_j nrow = SIZE(x, 2) ncol = SIZE(xij, 2) @@ -328,46 +354,22 @@ #endif orthopol0 = Input(default=polyopt%Monomial, option=basisType) -firstCall0 = Input(default=.TRUE., option=firstCall) - -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=aint, ncol=bint) - END IF - - coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) - -ELSE - - ! coeff0 = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & - nrow=aint, ncol=bint) +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 -IF (orthopol0 .EQ. polyopt%monomial) THEN - - xx(:, 1) = 1.0_DFP - DO ii = 1, order - xx(:, ii + 1) = xx(:, ii) * x(1, :) - END DO - -ELSE - - CALL EvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, alpha=alpha, & - beta=beta, lambda=lambda, ans=xx, nrow=aint, ncol=bint) - -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=coeff0(1:ncol, 1:ncol)) + B=coeff(1:ncol, 1:ncol)) -END PROCEDURE LagrangeEvalAll_Line2_ +END PROCEDURE LagrangeEvalAll_Line3_ !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Line diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 45bbc689c..80e5bbae1 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -201,6 +201,8 @@ !---------------------------------------------------------------------------- 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, & @@ -219,6 +221,17 @@ 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_ From d29a77fac3823fc390992084d9063abd2f99c896 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 27 Oct 2025 15:19:26 +0900 Subject: [PATCH 110/184] Updating QuadrangleInterpolationUtility --- .../src/QuadrangleInterpolationUtility.F90 | 61 ++++++++++ ...leInterpolationUtility@LagrangeMethods.F90 | 115 ++++++++++-------- 2 files changed, 128 insertions(+), 48 deletions(-) diff --git a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index 188cec7f7..c344df87a 100644 --- a/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -312,6 +312,26 @@ MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol) END SUBROUTINE LagrangeDegree_Quadrangle2_ END INTERFACE LagrangeDegree_Quadrangle_ +!---------------------------------------------------------------------------- +! MonomialBasis_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE MonomialBasis_Quadrangle_( & + 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) -> Number of points of evaluation + !! ncol = (p + 1) * (q + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MonomialBasis_Quadrangle_ +END INTERFACE + !---------------------------------------------------------------------------- ! LagrangeCoeff_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- @@ -737,6 +757,47 @@ MODULE SUBROUTINE LagrangeEvalAll_Quadrangle2_( & 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 index 82623b7aa..4b0cd5320 100644 --- a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 @@ -24,6 +24,12 @@ USE GE_CompRoutineMethods, ONLY: GetInvMat IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "QuadrangleInterpolationUtility@LagrangeMethods" +#endif + CONTAINS !---------------------------------------------------------------------------- @@ -109,6 +115,24 @@ 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 !---------------------------------------------------------------------------- @@ -375,72 +399,62 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Quadrangle2_ -LOGICAL(LGT) :: firstCall0, isCoeff -INTEGER(I4B) :: ii, jj, basisType0, indx(2), degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) ,xx(SIZE(x, 2), SIZE(xij, 2)), & - aval +LOGICAL(LGT) :: isok, firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -nrow = SIZE(x, 2) -ncol = SIZE(xij, 2) +firstCall0 = Input(default=.TRUE., option=firstCall) +isok = PRESENT(coeff) -basisType0 = INPUT(default=TypePolynomialOpt%monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) +IF (isok) THEN -isCoeff = PRESENT(coeff) + 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) -IF (isCoeff) THEN +ELSE - 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 + 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) - coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) +END IF +END PROCEDURE LagrangeEvalAll_Quadrangle2_ -ELSE +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Quadrangle_ +!---------------------------------------------------------------------------- - ! 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)) +MODULE PROCEDURE LagrangeEvalAll_Quadrangle3_ +INTEGER(I4B) :: basisType0, indx(2) -END IF +! coeff0(SIZE(xij, 2), SIZE(xij, 2)) +! xx(SIZE(x, 2), SIZE(xij, 2)) +! degree(SIZE(xij, 2), 2) -SELECT CASE (basisType0) +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) -CASE (TypePolynomialOpt%monomial) +basisType0 = INPUT(default=TypePolynomialOpt%Monomial, option=basisType) - ! degree = LagrangeDegree_Quadrangle(order=order) - CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & - ncol=indx(2)) +! 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)) -#ifdef DEBUG_VER - IF (ncol .NE. SIZE(degree, 1)) THEN - CALL Errormsg(msg="tdof is not same as size(degree,1)", & - routine="LagrangeEvalAll_Quadrangle1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF -#endif +SELECT CASE (basisType0) - DO ii = 1, ncol - indx(1:2) = degree(ii, 1:2) - DO jj = 1, nrow - aval = x(1, jj)**indx(1) * x(2, jj)**indx(2) - xx(jj, ii) = aval - END DO - END DO +CASE (TypePolynomialOpt%Monomial) + CALL MonomialBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & + nrow=indx(1), ncol=indx(2)) CASE (TypePolynomialOpt%Hierarchical) - ! xx = HeirarchicalBasis_Quadrangle( & CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & nrow=indx(1), ncol=indx(2)) CASE DEFAULT - - ! xx = TensorProdBasis_Quadrangle( & CALL TensorProdBasis_Quadrangle_( & p=order, q=order, xij=x, basisType1=basisType0, basisType2=basisType0, & alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & @@ -448,10 +462,13 @@ 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, B=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_Quadrangle2_ +END PROCEDURE LagrangeEvalAll_Quadrangle3_ !---------------------------------------------------------------------------- ! @@ -565,4 +582,6 @@ ! !---------------------------------------------------------------------------- +#include "../../include/errors.F90" + END SUBMODULE LagrangeMethods From 79a3fd30b99f7832797d5cf63d00c758dfebfe33 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 28 Oct 2025 08:16:58 +0900 Subject: [PATCH 111/184] Updating FEVariable_SetMethods --- .../FEVariable/src/FEVariable_GetMethod.F90 | 17 +++++++++++++++++ .../src/FEVariable_GetMethod@Methods.F90 | 9 +++++++++ .../src/FEVariable_SetMethod@MatrixMethods.F90 | 12 ++++++++++++ .../src/FEVariable_SetMethod@VectorMethods.F90 | 11 +++++++++++ 4 files changed, 49 insertions(+) diff --git a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 index b904400de..c1b107be0 100644 --- a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 @@ -32,6 +32,7 @@ MODULE FEVariable_GetMethod PUBLIC :: SIZE PUBLIC :: SHAPE +PUBLIC :: GetShape PUBLIC :: OPERATOR(.rank.) PUBLIC :: GetRank PUBLIC :: OPERATOR(.vartype.) @@ -170,6 +171,22 @@ MODULE PURE FUNCTION fevar_Shape(obj) RESULT(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 !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 index ffc16a9e8..b304dd2a9 100644 --- a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 @@ -166,6 +166,15 @@ ans(1:tsize) = obj%s(1:tsize) END PROCEDURE fevar_Shape +!---------------------------------------------------------------------------- +! Shape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_GetShape +tsize = GetTotalShape(obj=obj) +ans(1:tsize) = obj%s(1:tsize) +END PROCEDURE fevar_GetShape + !---------------------------------------------------------------------------- ! rank !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 index 1af1ddc5c..5349d382f 100644 --- a/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 @@ -26,6 +26,9 @@ 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 @@ -52,6 +55,9 @@ 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) @@ -81,6 +87,9 @@ 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) @@ -114,6 +123,9 @@ 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) diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 index 1ed9a6fef..1d26f32cf 100644 --- a/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 @@ -25,6 +25,8 @@ !---------------------------------------------------------------------------- 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 @@ -39,6 +41,9 @@ 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 @@ -65,6 +70,9 @@ 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) @@ -94,6 +102,9 @@ 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 From f3dbb11a0429282c919921b0ec37c54ea7a66b27 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 28 Oct 2025 08:17:11 +0900 Subject: [PATCH 112/184] Formatting in LineInterpolationUtility --- .../Line/src/LineInterpolationUtility.F90 | 49 +++++++------------ 1 file changed, 17 insertions(+), 32 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index 367a6a770..bb8e0f659 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -1110,6 +1110,17 @@ END SUBROUTINE LagrangeGradientEvalAll_Line1_ !> 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, & @@ -1121,13 +1132,7 @@ MODULE FUNCTION BasisEvalAll_Line1(order, x, refLine, basisType, alpha, & CHARACTER(*), INTENT(IN) :: refLine !! Refline should be BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! BasisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1157,13 +1162,7 @@ MODULE SUBROUTINE BasisEvalAll_Line1_(order, x, ans, tsize, refLine, & CHARACTER(*), INTENT(IN) :: refLine !! Refline should be BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! BasisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1189,16 +1188,9 @@ MODULE FUNCTION BasisEvalAll_Line2(order, x, refLine, basisType, & REAL(DFP), INTENT(IN) :: x(:) !! point of evaluation CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT, BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! BasisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1231,16 +1223,9 @@ MODULE SUBROUTINE BasisEvalAll_Line2_(order, x, ans, nrow, ncol, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns written to ans CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT, BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! basis type REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta From 20c55d154e7daee34ff603802d14335cb41313ea Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 28 Oct 2025 20:29:11 +0900 Subject: [PATCH 113/184] Added tShape in FEVariable --- src/modules/BaseType/src/BaseType.F90 | 15 ++++ .../FEVariable/src/FEVariable_GetMethod.F90 | 4 +- .../FEVariable_ConstructorMethod@Methods.F90 | 13 ++-- .../src/FEVariable_GetMethod@Methods.F90 | 72 ++++++++++--------- .../src/FEVariable_IOMethod@Methods.F90 | 1 + 5 files changed, 62 insertions(+), 43 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index f52121798..dbd452fee 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1104,6 +1104,21 @@ END SUBROUTINE highorder_refelem !! 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: 2 + !! 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 diff --git a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 index c1b107be0..fa7578bcd 100644 --- a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 @@ -60,8 +60,8 @@ MODULE FEVariable_GetMethod ! summary: Get lame parameter lambda from YoungsModulus INTERFACE GetLambdaFromYoungsModulus - MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus(youngsModulus, & - shearModulus, lambda) + MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus( & + youngsModulus, shearModulus, lambda) TYPE(FEVariable_), INTENT(IN) :: youngsModulus, shearModulus TYPE(FEVariable_), INTENT(INOUT) :: lambda END SUBROUTINE fevar_GetLambdaFromYoungsModulus diff --git a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 index 57108edc4..f4c60f83e 100644 --- a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 @@ -36,12 +36,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Initiate2 -INTEGER(I4B) :: tsize LOGICAL(LGT) :: isok +INTEGER(I4B) :: tsize -tsize = SIZE(s) +obj%tshape = SIZE(s) obj%isInit = .TRUE. -obj%s(1:tsize) = s(1:tsize) +obj%s(1:obj%tshape) = s(1:obj%tshape) obj%defineon = defineon obj%vartype = vartype obj%rank = rank @@ -69,14 +69,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Deallocate -IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) +obj%isInit = .FALSE. obj%s = 0 +obj%tshape = 0 obj%defineOn = 0 obj%vartype = 0 obj%rank = 0 obj%len = 0 obj%capacity = 0 -obj%isInit = .FALSE. +IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) END PROCEDURE obj_Deallocate !---------------------------------------------------------------------------- @@ -87,6 +88,7 @@ LOGICAL(LGT) :: isok obj1%s = obj2%s +obj1%tshape = obj2%tshape obj1%defineOn = obj2%defineOn obj1%rank = obj2%rank obj1%vartype = obj2%vartype @@ -103,7 +105,6 @@ isok = ALLOCATED(obj2%val) IF (isok) obj1%val(1:obj1%len) = obj2%val(1:obj1%len) - END PROCEDURE obj_Copy !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 index b304dd2a9..82e53bc5c 100644 --- a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 @@ -123,36 +123,37 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_GetTotalShape -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 +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 !---------------------------------------------------------------------------- @@ -160,10 +161,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Shape -INTEGER(I4B) :: tsize -tsize = GetTotalShape(obj=obj) -CALL Reallocate(ans, tsize) -ans(1:tsize) = obj%s(1:tsize) +! 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 !---------------------------------------------------------------------------- @@ -171,7 +172,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_GetShape -tsize = GetTotalShape(obj=obj) +! tsize = GetTotalShape(obj=obj) +tsize = obj%tshape ans(1:tsize) = obj%s(1:tsize) END PROCEDURE fevar_GetShape diff --git a/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 index 76fb2be99..25d53c643 100644 --- a/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 @@ -132,6 +132,7 @@ 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) From cfc02d60a5e981be8c909d46ba2f64e6b6a25b91 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 29 Oct 2025 17:03:24 +0900 Subject: [PATCH 114/184] Updating BeFor74 --- .../BeFoR64/src/befor64_pack_data_m.F90 | 93 +++++++++++-------- 1 file changed, 56 insertions(+), 37 deletions(-) diff --git a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 index aa0dd389b..dd8cabe7e 100644 --- a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 +++ b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 @@ -57,13 +57,16 @@ MODULE befor64_pack_data_m !<... ! 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 From 8a88ed9f83187622545bfd75260938a4e632bc20 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 29 Oct 2025 17:03:32 +0900 Subject: [PATCH 115/184] Updating PENF --- src/modules/PENF/src/penf_stringify.F90 | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/src/modules/PENF/src/penf_stringify.F90 b/src/modules/PENF/src/penf_stringify.F90 index e34edeedc..9360c656b 100644 --- a/src/modules/PENF/src/penf_stringify.F90 +++ b/src/modules/PENF/src/penf_stringify.F90 @@ -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 From 93e761cf64674d1d454388e03649c7e39aeabb1d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 29 Oct 2025 17:03:56 +0900 Subject: [PATCH 116/184] Adding Set method in QuadraturePoint --- .../src/QuadraturePoint_Method.F90 | 21 ++++++++++ src/submodules/QuadraturePoint/CMakeLists.txt | 3 +- .../src/QuadraturePoint_Method@SetMethods.F90 | 41 +++++++++++++++++++ 3 files changed, 64 insertions(+), 1 deletion(-) create mode 100644 src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 04dabf214..103ff5612 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -27,6 +27,7 @@ MODULE QuadraturePoint_Method PRIVATE +PUBLIC :: Set PUBLIC :: Initiate PUBLIC :: InitiateFacetQuadrature PUBLIC :: Copy @@ -1235,6 +1236,26 @@ MODULE SUBROUTINE obj_InitiateFacetQuadrature4(obj, facetQuad, & 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/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt index b568d81e9..218d4895d 100644 --- a/src/submodules/QuadraturePoint/CMakeLists.txt +++ b/src/submodules/QuadraturePoint/CMakeLists.txt @@ -21,4 +21,5 @@ target_sources( 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@FacetQuadratureMethods.F90 + ${src_path}/QuadraturePoint_Method@SetMethods.F90) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 new file mode 100644 index 000000000..d4f75dae1 --- /dev/null +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 @@ -0,0 +1,41 @@ +! 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) SetMethods +USE ReallocateUtility, ONLY: Reallocate +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +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 SetMethods From cbb39789a02796ce41c0afff704d5b24f7e5f511 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 4 Nov 2025 10:30:49 +0900 Subject: [PATCH 117/184] Updating QuadratureVariablesMethod adding a new method for scalar and space --- .../FEVariable_QuadratureVariableMethod.F90 | 142 +++++++++++++++--- ...iable_QuadratureVariableMethod@Methods.F90 | 14 ++ 2 files changed, 136 insertions(+), 20 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 index 5c8086557..125d677d0 100644 --- a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 @@ -41,7 +41,7 @@ MODULE FEVariable_QuadratureVariableMethod ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, Constant -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -49,6 +49,10 @@ MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_Constant +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Constant END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -60,7 +64,7 @@ END FUNCTION Quadrature_Scalar_Constant ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, Space -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -68,6 +72,32 @@ MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_Space +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Space +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! 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 !---------------------------------------------------------------------------- @@ -79,7 +109,7 @@ END FUNCTION Quadrature_Scalar_Space ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, Time -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -87,6 +117,10 @@ MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_Time +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Time END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -98,7 +132,7 @@ END FUNCTION Quadrature_Scalar_Time ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, SpaceTime -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -106,6 +140,10 @@ MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, vartype) & TYPE(FEVariableScalar_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Scalar_SpaceTime +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_SpaceTime END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -117,7 +155,7 @@ END FUNCTION Quadrature_Scalar_SpaceTime ! update: 2021-12-10 ! summary: Create quadrature variable, which is Scalar, SpaceTime -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -126,6 +164,10 @@ MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -137,7 +179,7 @@ END FUNCTION Quadrature_Scalar_SpaceTime2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Constant -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -145,6 +187,10 @@ MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Quadrature_Vector_Constant +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Constant END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -156,7 +202,7 @@ END FUNCTION Quadrature_Vector_Constant ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Space -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -164,6 +210,10 @@ MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Quadrature_Vector_Space +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Space END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -175,7 +225,7 @@ END FUNCTION Quadrature_Vector_Space ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Space -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & RESULT(obj) @@ -185,6 +235,10 @@ MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -196,7 +250,7 @@ END FUNCTION Quadrature_Vector_Space2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Time -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_Time(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -204,6 +258,10 @@ MODULE PURE FUNCTION Quadrature_Vector_Time(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Vector_Time +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Time END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -215,7 +273,7 @@ END FUNCTION Quadrature_Vector_Time ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, Time -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_Time2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -224,6 +282,10 @@ MODULE PURE FUNCTION Quadrature_Vector_Time2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -235,7 +297,7 @@ END FUNCTION Quadrature_Vector_Time2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, SpaceTime -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -243,6 +305,10 @@ MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Vector_SpaceTime +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_SpaceTime END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -254,7 +320,7 @@ END FUNCTION Quadrature_Vector_SpaceTime ! update: 2021-12-10 ! summary: Create quadrature variable, which is Vector, SpaceTime -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Vector_SpaceTime2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -263,6 +329,10 @@ MODULE PURE FUNCTION Quadrature_Vector_SpaceTime2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -274,7 +344,7 @@ END FUNCTION Quadrature_Vector_SpaceTime2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Constant -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -282,6 +352,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) & TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Quadrature_Matrix_Constant +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Constant END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -293,7 +367,7 @@ END FUNCTION Quadrature_Matrix_Constant ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Constant -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_Constant2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -302,6 +376,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_Constant2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -313,7 +391,7 @@ END FUNCTION Quadrature_Matrix_Constant2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Space -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_Space(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -321,6 +399,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_Space(val, rank, vartype) & TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableSpace_), INTENT(IN) :: vartype END FUNCTION Quadrature_Matrix_Space +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Space END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -332,7 +414,7 @@ END FUNCTION Quadrature_Matrix_Space ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Space -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_Space2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -341,6 +423,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_Space2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -352,7 +438,7 @@ END FUNCTION Quadrature_Matrix_Space2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Time -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_Time(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -360,6 +446,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_Time(val, rank, vartype) & TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Matrix_Time +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Time END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -371,7 +461,7 @@ END FUNCTION Quadrature_Matrix_Time ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, Time -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_Time2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -380,6 +470,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_Time2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -391,7 +485,7 @@ END FUNCTION Quadrature_Matrix_Time2 ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, SpaceTime -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -399,6 +493,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) & TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype END FUNCTION Quadrature_Matrix_SpaceTime +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_SpaceTime END INTERFACE QuadratureVariable !---------------------------------------------------------------------------- @@ -410,7 +508,7 @@ END FUNCTION Quadrature_Matrix_SpaceTime ! update: 2021-12-10 ! summary: Create quadrature variable, which is Matrix, SpaceTime -INTERFACE QuadratureVariable +INTERFACE MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -419,6 +517,10 @@ MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime2(val, rank, vartype, s) & 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/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 index 91cd4b27c..0930edd81 100644 --- a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -52,6 +52,20 @@ 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 !---------------------------------------------------------------------------- From d5bf877708182704bebc03df30c99c6075827b82 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 4 Nov 2025 10:38:37 +0900 Subject: [PATCH 118/184] Updating NodalVariableMethod adding new method for scalar, space --- .../src/FEVariable_NodalVariableMethod.F90 | 144 +++++++++++++++--- ...FEVariable_NodalVariableMethod@Methods.F90 | 132 ++-------------- 2 files changed, 136 insertions(+), 140 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 index 26b1d7694..4c7f51bff 100644 --- a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 @@ -41,7 +41,7 @@ MODULE FEVariable_NodalVariableMethod ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, constant -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -49,6 +49,10 @@ MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) & CLASS(FEVariableScalar_), INTENT(IN) :: rank CLASS(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Nodal_Scalar_Constant +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_Constant END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -60,7 +64,7 @@ END FUNCTION Nodal_Scalar_Constant ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, Space -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -68,6 +72,32 @@ MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) & 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 !---------------------------------------------------------------------------- @@ -79,7 +109,7 @@ END FUNCTION Nodal_Scalar_Space ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, Time -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -87,6 +117,10 @@ MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) & 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 !---------------------------------------------------------------------------- @@ -98,7 +132,7 @@ END FUNCTION Nodal_Scalar_Time ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, SpaceTime -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Scalar_SpaceTime(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -106,6 +140,10 @@ MODULE PURE FUNCTION Nodal_Scalar_SpaceTime(val, rank, vartype) & 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 !---------------------------------------------------------------------------- @@ -117,7 +155,7 @@ END FUNCTION Nodal_Scalar_SpaceTime ! update: 2021-12-10 ! summary: Create nodal variable, which is scalar, SpaceTime -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Scalar_SpaceTime2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -126,6 +164,10 @@ MODULE PURE FUNCTION Nodal_Scalar_SpaceTime2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -137,7 +179,7 @@ END FUNCTION Nodal_Scalar_SpaceTime2 ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Constant -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -145,6 +187,10 @@ MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Nodal_Vector_Constant +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Constant END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -156,13 +202,17 @@ END FUNCTION Nodal_Vector_Constant ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Space -INTERFACE NodalVariable +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 !---------------------------------------------------------------------------- @@ -174,7 +224,7 @@ END FUNCTION Nodal_Vector_Space ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Space -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Vector_Space2(val, rank, vartype, s) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:) @@ -182,6 +232,10 @@ MODULE PURE FUNCTION Nodal_Vector_Space2(val, rank, vartype, s) RESULT(obj) 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 !---------------------------------------------------------------------------- @@ -193,13 +247,17 @@ END FUNCTION Nodal_Vector_Space2 ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Time -INTERFACE NodalVariable +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 !---------------------------------------------------------------------------- @@ -211,7 +269,7 @@ END FUNCTION Nodal_Vector_Time ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, Time -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Vector_Time2(val, rank, vartype, s) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:) @@ -219,6 +277,10 @@ MODULE PURE FUNCTION Nodal_Vector_Time2(val, rank, vartype, s) RESULT(obj) 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 !---------------------------------------------------------------------------- @@ -230,7 +292,7 @@ END FUNCTION Nodal_Vector_Time2 ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, SpaceTime -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -238,6 +300,10 @@ MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) & TYPE(FEVariableVector_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype END FUNCTION Nodal_Vector_SpaceTime +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_SpaceTime END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -249,7 +315,7 @@ END FUNCTION Nodal_Vector_SpaceTime ! update: 2021-12-10 ! summary: Create nodal variable, which is vector, SpaceTime -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Vector_SpaceTime2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -258,6 +324,10 @@ MODULE PURE FUNCTION Nodal_Vector_SpaceTime2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -269,7 +339,7 @@ END FUNCTION Nodal_Vector_SpaceTime2 ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Constant -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) & & RESULT(obj) TYPE(FEVariable_) :: obj @@ -277,6 +347,10 @@ MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) & TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableConstant_), INTENT(IN) :: vartype END FUNCTION Nodal_Matrix_Constant +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Constant END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -288,7 +362,7 @@ END FUNCTION Nodal_Matrix_Constant ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Constant -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Matrix_Constant2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -297,6 +371,10 @@ MODULE PURE FUNCTION Nodal_Matrix_Constant2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- @@ -308,13 +386,17 @@ END FUNCTION Nodal_Matrix_Constant2 ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Space -INTERFACE NodalVariable +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 !---------------------------------------------------------------------------- @@ -326,7 +408,7 @@ END FUNCTION Nodal_Matrix_Space ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Space -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Matrix_Space2(val, rank, vartype, s) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:) @@ -334,6 +416,10 @@ MODULE PURE FUNCTION Nodal_Matrix_Space2(val, rank, vartype, s) RESULT(obj) 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 !---------------------------------------------------------------------------- @@ -345,13 +431,17 @@ END FUNCTION Nodal_Matrix_Space2 ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Time -INTERFACE NodalVariable +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 !---------------------------------------------------------------------------- @@ -363,7 +453,7 @@ END FUNCTION Nodal_Matrix_Time ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, Time -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Matrix_Time2(val, rank, vartype, s) RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:) @@ -371,6 +461,10 @@ MODULE PURE FUNCTION Nodal_Matrix_Time2(val, rank, vartype, s) RESULT(obj) 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 !---------------------------------------------------------------------------- @@ -382,7 +476,7 @@ END FUNCTION Nodal_Matrix_Time2 ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, SpaceTime -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -390,6 +484,10 @@ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) & TYPE(FEVariableMatrix_), INTENT(IN) :: rank TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype END FUNCTION Nodal_Matrix_SpaceTime +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_SpaceTime END INTERFACE NodalVariable !---------------------------------------------------------------------------- @@ -401,7 +499,7 @@ END FUNCTION Nodal_Matrix_SpaceTime ! update: 2021-12-10 ! summary: Create nodal variable, which is Matrix, SpaceTime -INTERFACE NodalVariable +INTERFACE MODULE PURE FUNCTION Nodal_Matrix_SpaceTime2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -410,10 +508,14 @@ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime2(val, rank, vartype, s) & 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 !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- END MODULE FEVariable_NodalVariableMethod diff --git a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 index 1b0161376..fe5d9652b 100644 --- a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 @@ -27,12 +27,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Scalar_Constant -! #define _DEFINEON_ Nodal -! #include "./include/scalar_constant.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Scalar_Constant - MODULE PROCEDURE Nodal_Scalar_Constant INTEGER(I4B) :: s(1) @@ -47,12 +41,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Scalar_Space -! #define _DEFINEON_ Nodal -! #include "./include/scalar_space.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Scalar_Space - MODULE PROCEDURE Nodal_Scalar_Space INTEGER(I4B) :: s(1) @@ -67,11 +55,19 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Scalar_Time -! #define _DEFINEON_ Nodal -! #include "./include/scalar_time.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Scalar_Time +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) @@ -87,12 +83,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Scalar_SpaceTime -! #define _DEFINEON_ Nodal -! #include "./include/scalar_space_time.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Scalar_SpaceTime - MODULE PROCEDURE Nodal_Scalar_SpaceTime INTEGER(I4B) :: s(2), tsize, ii, jj, kk s = SHAPE(val) @@ -115,12 +105,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Scalar_SpaceTime2 -! #define _DEFINEON_ Nodal -! #include "./include/scalar_space_time2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Scalar_SpaceTime2 - MODULE PROCEDURE Nodal_Scalar_SpaceTime2 INTEGER(I4B) :: tsize @@ -136,12 +120,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_Constant -! #define _DEFINEON_ Nodal -! #include "./include/vector_constant.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_Constant - MODULE PROCEDURE Nodal_Vector_Constant INTEGER(I4B) :: s(1), tsize @@ -159,12 +137,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_Space -! #define _DEFINEON_ Nodal -! #include "./include/vector_space.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_Space - MODULE PROCEDURE Nodal_Vector_Space INTEGER(I4B) :: s(2), tsize, ii, jj, cnt @@ -188,12 +160,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_Space2 -! #define _DEFINEON_ Nodal -! #include "./include/vector_space2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_Space2 - MODULE PROCEDURE Nodal_Vector_Space2 INTEGER(I4B) :: tsize @@ -209,12 +175,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_Time -! #define _DEFINEON_ Nodal -! #include "./include/vector_time.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_Time - MODULE PROCEDURE Nodal_Vector_Time INTEGER(I4B) :: s(2), tsize, ii, jj, cnt @@ -238,12 +198,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_Time2 -! #define _DEFINEON_ Nodal -! #include "./include/vector_time2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_Time2 - MODULE PROCEDURE Nodal_Vector_Time2 INTEGER(I4B) :: tsize @@ -259,12 +213,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_SpaceTime -! #define _DEFINEON_ Nodal -! #include "./include/vector_space_time.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_SpaceTime - MODULE PROCEDURE Nodal_Vector_SpaceTime INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt s = SHAPE(val) @@ -288,12 +236,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Vector_SpaceTime2 -! #define _DEFINEON_ Nodal -! #include "./include/vector_space_time2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Vector_SpaceTime2 - MODULE PROCEDURE Nodal_Vector_SpaceTime2 INTEGER(I4B) :: tsize @@ -308,12 +250,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_Constant -! #define _DEFINEON_ Nodal -! #include "./include/matrix_constant.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_Constant - MODULE PROCEDURE Nodal_Matrix_Constant INTEGER(I4B) :: s(2), tsize, ii, jj, cnt @@ -338,12 +274,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_Constant2 -! #define _DEFINEON_ Nodal -! #include "./include/matrix_constant2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_Constant2 - MODULE PROCEDURE Nodal_Matrix_Constant2 INTEGER(I4B) :: tsize @@ -357,12 +287,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_Space -! #define _DEFINEON_ Nodal -! #include "./include/matrix_space.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_Space - MODULE PROCEDURE Nodal_Matrix_Space INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt @@ -387,12 +311,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_Space2 -! #define _DEFINEON_ Nodal -! #include "./include/matrix_space2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_Space2 - MODULE PROCEDURE Nodal_Matrix_Space2 INTEGER(I4B) :: tsize @@ -407,12 +325,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_Time -! #define _DEFINEON_ Nodal -! #include "./include/matrix_time.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_Time - MODULE PROCEDURE Nodal_Matrix_Time INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt @@ -438,12 +350,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_Time2 -! #define _DEFINEON_ Nodal -! #include "./include/matrix_time2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_Time2 - MODULE PROCEDURE Nodal_Matrix_Time2 INTEGER(I4B) :: tsize @@ -460,12 +366,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_SpaceTime -! #define _DEFINEON_ Nodal -! #include "./include/matrix_space_time.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_SpaceTime - MODULE PROCEDURE Nodal_Matrix_SpaceTime INTEGER(I4B) :: s(4), tsize, ii, jj, kk, ll, cnt @@ -493,12 +393,6 @@ ! NodalVariable !---------------------------------------------------------------------------- -! MODULE PROCEDURE Nodal_Matrix_SpaceTime2 -! #define _DEFINEON_ Nodal -! #include "./include/matrix_space_time2.F90" -! #undef _DEFINEON_ -! END PROCEDURE Nodal_Matrix_SpaceTime2 - MODULE PROCEDURE Nodal_Matrix_SpaceTime2 INTEGER(I4B) :: tsize From e6995fb5c4665ab57dba71e71432b6e91cdba2a5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 4 Nov 2025 11:55:06 +0900 Subject: [PATCH 119/184] Updating FEVariable and ElemshapeData Updates are fixing a bug in GetInterpolation method --- .../src/ElemshapeData_InterpolMethods.F90 | 38 ++++++++-- .../src/FEVariable_InterpolationMethod.F90 | 12 +-- .../FEVariable/src/FEVariable_Method.F90 | 6 +- .../FEVariable_ScalarInterpolationMethod.F90 | 76 ++++++------------- ...able_ScalarInterpolationMethod@Methods.F90 | 3 + 5 files changed, 64 insertions(+), 71 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index b8e9aa316..b76509037 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -59,12 +59,16 @@ MODULE ElemshapeData_InterpolMethods ! we do not have time shape function for ! all quadrature points in time in obj) -INTERFACE GetInterpolation +INTERFACE MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE GetInterpolation1 +END INTERFACE + +INTERFACE GetInterpolation + MODULE PROCEDURE GetInterpolation1 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- @@ -87,12 +91,16 @@ END SUBROUTINE GetInterpolation1 ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime -INTERFACE GetInterpolation_ +INTERFACE MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE GetInterpolation_1 +END INTERFACE + +INTERFACE GetInterpolation_ + MODULE PROCEDURE GetInterpolation_1 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- @@ -115,7 +123,7 @@ END SUBROUTINE GetInterpolation_1 ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime ! -INTERFACE GetInterpolation_ +INTERFACE MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, scale, & addContribution) CLASS(ElemshapeData_), INTENT(IN) :: obj @@ -124,6 +132,10 @@ MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, scale, & REAL(DFP), INTENT(IN) :: scale LOGICAL, INTENT(IN) :: addContribution END SUBROUTINE GetInterpolation_1a +END INTERFACE + +INTERFACE GetInterpolation_ + MODULE PROCEDURE GetInterpolation_1a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- @@ -150,12 +162,16 @@ END SUBROUTINE GetInterpolation_1a ! ! - ans will Quadrature and SpaceTime -INTERFACE GetInterpolation +INTERFACE MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val END SUBROUTINE GetInterpolation2 +END INTERFACE + +INTERFACE GetInterpolation + MODULE PROCEDURE GetInterpolation2 END INTERFACE GetInterpolation !---------------------------------------------------------------------------- @@ -178,12 +194,16 @@ END SUBROUTINE GetInterpolation2 ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime ! -INTERFACE GetInterpolation_ +INTERFACE 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 GetInterpolation_2 +END INTERFACE + +INTERFACE GetInterpolation_ + MODULE PROCEDURE GetInterpolation_2 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- @@ -206,7 +226,7 @@ END SUBROUTINE GetInterpolation_2 ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime -INTERFACE GetInterpolation_ +INTERFACE MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, scale, & addContribution) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) @@ -215,10 +235,14 @@ MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, scale, & REAL(DFP), INTENT(IN) :: scale LOGICAL, INTENT(IN) :: addContribution END SUBROUTINE GetInterpolation_2a +END INTERFACE + +INTERFACE GetInterpolation_ + MODULE PROCEDURE GetInterpolation_2a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! Interpolation@Methods +! Interpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. diff --git a/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 index 221426688..1d06938b2 100644 --- a/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 @@ -34,10 +34,8 @@ MODULE FEVariable_InterpolationMethod ! summary: Get interpolation of Matrix, space-time INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE FEVariableGetInterpolation_1(obj, N, nns, nips, & - scale, & - addContribution, & - ans) + 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 @@ -65,10 +63,8 @@ END SUBROUTINE FEVariableGetInterpolation_1 ! summary: Get interpolation of Matrix, space-time INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE FEVariableGetInterpolation_2(obj, N, nns, nips, & - T, nnt, scale, & - addContribution, & - timeIndx, ans) + 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 diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index d889b6f6d..dea120835 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -22,16 +22,16 @@ MODULE FEVariable_Method USE FEVariable_DotProductMethod USE FEVariable_GetMethod USE FEVariable_IOMethod -USE FEVariable_InterpolationMethod -USE FEVariable_MatrixInterpolationMethod USE FEVariable_MeanMethod USE FEVariable_MultiplicationMethod USE FEVariable_NodalVariableMethod USE FEVariable_QuadratureVariableMethod -USE FEVariable_ScalarInterpolationMethod 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_ScalarInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 index fbbfd61d4..47edd3db7 100644 --- a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 @@ -40,11 +40,8 @@ MODULE FEVariable_ScalarInterpolationMethod ! summary: Get interpolation of scalar, constant INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_1(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - ans, tsize) + 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 @@ -76,11 +73,8 @@ END SUBROUTINE ScalarConstantGetInterpolation_1 ! summary: Get interpolation of scalar, constant INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_2(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - timeIndx, ans) + 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 @@ -112,11 +106,9 @@ END SUBROUTINE ScalarConstantGetInterpolation_2 ! summary: Get interpolation of scalar, constant INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_3(obj, rank, vartype, & - N, nns, spaceIndx, & - timeIndx, scale, & - addContribution, & - ans) + 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 @@ -148,11 +140,8 @@ END SUBROUTINE ScalarConstantGetInterpolation_3 ! summary: Get interpolation of scalar, space INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_1(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - ans, tsize) + 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 @@ -184,11 +173,8 @@ END SUBROUTINE ScalarSpaceGetInterpolation_1 ! summary: Get interpolation of scalar, space INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_2(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - timeIndx, ans) + 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 @@ -220,11 +206,9 @@ END SUBROUTINE ScalarSpaceGetInterpolation_2 ! summary: Get interpolation of scalar, space INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_3(obj, rank, vartype, & - N, nns, spaceIndx, & - timeIndx, scale, & - addContribution, & - ans) + 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 @@ -254,14 +238,9 @@ END SUBROUTINE ScalarSpaceGetInterpolation_3 ! 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) + 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 @@ -310,13 +289,9 @@ END SUBROUTINE ScalarSpaceTimeGetInterpolation_1 ! END DO INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_2(obj, rank, & - vartype, & - N, nns, nips, & - T, nnt, & - scale, & - addContribution, & - timeIndx, ans) + 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 @@ -352,14 +327,9 @@ END SUBROUTINE ScalarSpaceTimeGetInterpolation_2 ! 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) + 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 diff --git a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 index e406d93b9..28a3dd0c2 100644 --- a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 @@ -152,6 +152,9 @@ END SUBROUTINE MasterGetInterpolation3_ 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) From a1df70b56d5b77df295b9955c3e319ed1e1f4e20 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 5 Nov 2025 08:12:06 +0900 Subject: [PATCH 120/184] Updating QuadrangleInterpolationUtility Fixing a bug in evaluating gradient of heirarchical shape functions --- ...terpolationUtility@HierarchicalMethods.F90 | 50 ++++++++++--------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 index baf505d98..81b2f7e74 100644 --- a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 @@ -117,7 +117,6 @@ PURE SUBROUTINE VertexBasisGradient_Quadrangle2_(L1, L2, dL1, dL2, & 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_ !---------------------------------------------------------------------------- @@ -304,8 +303,8 @@ PURE SUBROUTINE LeftVerticalEdgeBasisGradient_Quadrangle_( & dim3 = 2 DO CONCURRENT(k2=2:order, ii=1:dim1) - ans(ii, offset + k2 - 1, 1) = (mysign**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2) - ans(ii, offset + k2 - 1, 2) = (mysign**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2) + 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_ @@ -348,8 +347,8 @@ PURE SUBROUTINE RightVerticalEdgeBasisGradient_Quadrangle_( & ! Right vertical DO CONCURRENT(k2=2:order, ii=1:dim1) - ans(ii, offset + k2 - 1, 1) = (mysign**(k2 - 1)) * dL1(ii, 1) * L2(ii, k2) - ans(ii, offset + k2 - 1, 2) = (mysign**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2) + 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_ @@ -497,8 +496,8 @@ PURE SUBROUTINE BottomHorizontalEdgeBasisGradient_Quadrangle_( & !! bottom edge DO CONCURRENT(k1=2:order, ii=1:dim1) - ans(ii, offset + k1 - 1, 1) = (mysign**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0) - ans(ii, offset + k1 - 1, 2) = (mysign**(k1 - 1)) * L1(ii, k1) * dL2(ii, 0) + 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_ @@ -537,10 +536,9 @@ PURE SUBROUTINE TopHorizontalEdgeBasisGradient_Quadrangle_( & !! top edge DO CONCURRENT(k1=2:order, ii=1:dim1) - ans(ii, offset + k1 - 1, 1) = (mysign**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1) - ans(ii, offset + k1 - 1, 2) = (mysign**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1) + 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_ !---------------------------------------------------------------------------- @@ -601,12 +599,11 @@ PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & 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 - ELSE - p = pb - q = qb END IF DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) @@ -648,21 +645,20 @@ PURE SUBROUTINE CellBasisGradient_Quadrangle2_( & 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 - ELSE - p = pb - q = qb 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 - 1)) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) + (o1**k1) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 2) = & - (o1**k1) * (o2**(k2 - 1)) * L1(ii, k1) * dL2(ii, k2) + (o1**k1) * (o2**k2) * L1(ii, k1) * dL2(ii, k2) END DO END SUBROUTINE CellBasisGradient_Quadrangle2_ @@ -888,13 +884,15 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ 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)) +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) @@ -908,7 +906,7 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ END IF ! Right Vertical Edge basis function -isok = (qe1 .GE. 2_I4B) +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), & @@ -926,11 +924,11 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ END IF ! Left Vertical Edge basis function -isok = (qe2 .GE. 2_I4B) +isok = (qe1 .GE. 2_I4B) IF (isok) THEN CALL LeftVerticalEdgeBasisGradient_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) + 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 @@ -948,4 +946,8 @@ END SUBROUTINE CellBasisGradient_Quadrangle2_ DEALLOCATE (L1, L2, dL1, dL2) END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE HierarchicalMethods From c3326673c4d301c9587c632bc7cd33a38c389fb5 Mon Sep 17 00:00:00 2001 From: shion Date: Wed, 5 Nov 2025 18:35:29 +0900 Subject: [PATCH 121/184] Updates in LineInterpolationUtility - fixing minor issues - setting proper number of gauss points for Radau type quadratures - sorting with explicit range for "INC" case in getting interpolation points --- .../src/LineInterpolationUtility@InterpolationMethods.F90 | 2 +- .../Line/src/LineInterpolationUtility@QuadratureMethods.F90 | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 index 7e88f4c44..db12306a6 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 @@ -391,7 +391,7 @@ SUBROUTINE handle_increasing !! layout INCREASING IF (layout(1:1) .EQ. "I") THEN DO ii = 1, nrow - CALL HeapSort(ans(ii, :)) + CALL HeapSort(ans(ii, 1:ncol)) END DO END IF END SUBROUTINE diff --git a/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 index a2a42db6b..21c8daaf6 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 @@ -42,6 +42,11 @@ 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 From ed36bbee0d24725d20e20a5415f3a8005594f2da Mon Sep 17 00:00:00 2001 From: shion Date: Sat, 8 Nov 2025 13:28:21 +0900 Subject: [PATCH 122/184] Updates in FEVariable - adding a few methods --- .../src/FEVariable_NodalVariableMethod.F90 | 22 ++++++++++++++++++ .../FEVariable_QuadratureVariableMethod.F90 | 23 ++++++++++++++++++- ...FEVariable_NodalVariableMethod@Methods.F90 | 18 +++++++++++++++ ...iable_QuadratureVariableMethod@Methods.F90 | 18 +++++++++++++++ 4 files changed, 80 insertions(+), 1 deletion(-) diff --git a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 index 4c7f51bff..163b5e663 100644 --- a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 @@ -242,6 +242,28 @@ END FUNCTION Nodal_Vector_Space2 ! 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 diff --git a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 index 125d677d0..a387b170a 100644 --- a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 @@ -226,7 +226,6 @@ END FUNCTION Quadrature_Vector_Space ! summary: Create quadrature variable, which is Vector, Space INTERFACE - MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & RESULT(obj) TYPE(FEVariable_) :: obj @@ -245,6 +244,28 @@ END FUNCTION Quadrature_Vector_Space2 ! 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 diff --git a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 index fe5d9652b..698217e43 100644 --- a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 @@ -171,6 +171,24 @@ 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) + +obj%val(1:obj%len) = 0.0_DFP +END PROCEDURE Nodal_Vector_Space3 + !---------------------------------------------------------------------------- ! NodalVariable !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 index 0930edd81..195faf2db 100644 --- a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -170,6 +170,24 @@ 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 !---------------------------------------------------------------------------- From 949bfffaabb41839c7be2718c2e1f7de152fa92a Mon Sep 17 00:00:00 2001 From: shion Shimizu Date: Sun, 9 Nov 2025 00:49:11 +0900 Subject: [PATCH 123/184] Fixing bug in Stiffness matrix - minor changes --- .../StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 index e61619ce8..8e675cde2 100644 --- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 +++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 @@ -473,7 +473,7 @@ BMat1(test%nsd * test%nns, test%nsd * test%nsd), & BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd) INTEGER(I4B) :: nips, nns1, nns2, ii, jj, ips, nsd -INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: indx(3, 3) nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) From e9c7247c5151cb43d2e5c495674b3ce9b2d50cec Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 10 Nov 2025 10:00:02 +0900 Subject: [PATCH 124/184] Updating MassMatrix --- src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 0ba2e0420..44469b204 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -256,6 +256,7 @@ END SUBROUTINE MM_2d REAL(DFP) :: realval(trial%nips) REAL(DFP), PARAMETER :: one = 1.0_DFP INTEGER(I4B) :: ips, ii, jj +LOGICAL(LGT) :: isopt nrow = test%nns ncol = trial%nns @@ -263,14 +264,15 @@ END SUBROUTINE MM_2d CALL GetInterpolation_(obj=trial, ans=realval, val=rho, tsize=ii) realval = trial%js * trial%ws * trial%thickness * realval -DO ips = 1, SIZE(realval) +DO ips = 1, test%nips CALL OuterProd_(a=test%N(1:nrow, ips), & b=trial%N(1:ncol, ips), & nrow=ii, ncol=jj, ans=ans, scale=realval(ips), & anscoeff=one) END DO -IF (PRESENT(opt)) THEN +isopt = PRESENT(opt) +IF (isopt) THEN CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) nrow = opt * nrow ncol = opt * ncol From 7dcbeaf3133b71a8cbab0b0ae5c4fffc9df2c2ef Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 11 Nov 2025 15:07:50 +0900 Subject: [PATCH 125/184] Minor update in FEVariable_ --- src/modules/BaseType/src/BaseType.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index dbd452fee..83e402a2a 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -1113,7 +1113,7 @@ END SUBROUTINE highorder_refelem !! Scalar, spaceTime: 2 !! Vector, constant: 1 !! Vector, space: 2 - !! Vector, time: 2 + !! Vector, time: 3 !! Vector, spaceTime: 3 !! Matrix, constant: 2 !! Matrix, space: 3 From beca875fd892c124819d6f4273a2bf9e049baaa1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 08:22:39 +0900 Subject: [PATCH 126/184] Updating CSRMatrix_SetMethods Removing BaseMethod use --- .../CSRMatrix/src/CSRMatrix_SetMethods.F90 | 34 +++++++++++++++ .../src/CSRMatrix_SetMethods@Methods.F90 | 41 +++++++++++++++---- .../DOF/src/DOF_GetMethods@Methods.F90 | 8 ++-- 3 files changed, 70 insertions(+), 13 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 index 127461fde..e01f017f1 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 @@ -577,4 +577,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/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 index 8283f5447..8dd0c5f68 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 @@ -20,7 +20,15 @@ ! 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 CSRMatrix_GetMethods, ONLY: OPERATOR(.StorageFMT.) +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 + IMPLICIT NONE CONTAINS @@ -41,8 +49,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 +80,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 +386,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 +397,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 +405,22 @@ !---------------------------------------------------------------------------- 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) :: istart_lhs, iend_lhs, istride_lhs +INTEGER(I4B) :: istart_rhs, iend_rhs, istride_rhs + +scale0 = Input(default=1.0_DFP, option=scale) + +! obj%A(istart_lhs:iend_lhs:istride_lhs) = scale0 * VALUE(istart_rhs:iend_rhs:istride_rhs) + +END PROCEDURE obj_SetToSTMatrix1 + END SUBMODULE Methods diff --git a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 index 5b0844851..fa76e9c91 100644 --- a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 +++ b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 @@ -679,7 +679,7 @@ END PROCEDURE obj_GetNodeLoc_13 !---------------------------------------------------------------------------- -! GetIndex +! GetIndex !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex1 @@ -691,7 +691,7 @@ END PROCEDURE obj_GetIndex1 !---------------------------------------------------------------------------- -! GetIndex_ +! GetIndex_ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex_1 @@ -701,7 +701,7 @@ END PROCEDURE obj_GetIndex_1 !---------------------------------------------------------------------------- -! GetIndex +! GetIndex !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex2 @@ -713,7 +713,7 @@ END PROCEDURE obj_GetIndex2 !---------------------------------------------------------------------------- -! GetIndex_ +! GetIndex_ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex_2 From e1623ff6a76dc99d2d7d223602793ad4211e625f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 11:39:17 +0900 Subject: [PATCH 127/184] Updating CSRMatrix --- .../CSRMatrix/src/CSRMatrix_AddMethods.F90 | 90 ++++- .../src/CSRMatrix_AddMethods@Methods.F90 | 370 +++++++++--------- 2 files changed, 274 insertions(+), 186 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 index 245733347..0264c613f 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 @@ -21,6 +21,47 @@ MODULE CSRMatrix_AddMethods PRIVATE PUBLIC :: 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 @@ -128,7 +169,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 @@ -173,7 +214,6 @@ END SUBROUTINE obj_Add5 !$$ ! obj(Nptrs,Nptrs)=value(:,:) !$$ -! INTERFACE Add MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, & @@ -193,8 +233,8 @@ END SUBROUTINE obj_Add6 !---------------------------------------------------------------------------- !> 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 +257,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 @@ -483,8 +523,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 +538,40 @@ MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, & END SUBROUTINE 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/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 index 15664fcb3..e8f5c344f 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 @@ -20,24 +20,42 @@ ! 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.) +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_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,6 +64,46 @@ 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 @@ -65,7 +123,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 +131,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 @@ -95,10 +153,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 +168,13 @@ !---------------------------------------------------------------------------- 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) -! + +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) + END PROCEDURE obj_Add4 !---------------------------------------------------------------------------- @@ -122,10 +184,14 @@ 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 @@ -137,24 +203,13 @@ 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 !---------------------------------------------------------------------------- @@ -162,20 +217,12 @@ !---------------------------------------------------------------------------- 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) -! +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) END PROCEDURE obj_Add7 !---------------------------------------------------------------------------- @@ -185,21 +232,11 @@ 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 @@ -210,21 +247,12 @@ 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) + 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) END PROCEDURE obj_Add9 !---------------------------------------------------------------------------- @@ -234,21 +262,10 @@ 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 @@ -260,24 +277,12 @@ 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 !---------------------------------------------------------------------------- @@ -287,24 +292,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 @@ -316,27 +311,15 @@ 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 !---------------------------------------------------------------------------- @@ -346,27 +329,15 @@ 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) +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_Add14 !---------------------------------------------------------------------------- @@ -374,6 +345,11 @@ !---------------------------------------------------------------------------- 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 +362,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 From 31db7fe5cff3ece1bd2adc5ffdd8705644443821 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 11:39:30 +0900 Subject: [PATCH 128/184] Updating CSRMatrix GetMethods --- .../CSRMatrix/src/CSRMatrix_SetMethods.F90 | 1 + .../src/CSRMatrix_SetMethods@Methods.F90 | 35 ++++++++++++++++--- 2 files changed, 32 insertions(+), 4 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 index e01f017f1..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 diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 index 8dd0c5f68..7e9f07ab0 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 @@ -22,13 +22,16 @@ SUBMODULE(CSRMatrix_SetMethods) Methods USE GlobalData, ONLY: FMT_NODES, FMT_DOF, NodesToDOF, DofToNodes USE DOF_Method, ONLY: GetIndex, GetNodeLoc, OPERATOR(.tdof.) -USE CSRMatrix_GetMethods, ONLY: OPERATOR(.StorageFMT.) 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 @@ -414,12 +417,36 @@ MODULE PROCEDURE obj_SetToSTMatrix1 REAL(DFP) :: scale0 -INTEGER(I4B) :: istart_lhs, iend_lhs, istride_lhs -INTEGER(I4B) :: istart_rhs, iend_rhs, istride_rhs +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) -! obj%A(istart_lhs:iend_lhs:istride_lhs) = scale0 * VALUE(istart_rhs:iend_rhs:istride_rhs) +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 From b86f55c02c48e6dd6ef9bfb936455df022ca50b4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 11:39:36 +0900 Subject: [PATCH 129/184] Updating CSRMatrix --- src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 index 1a66b9b33..1eb94dfe0 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 @@ -165,7 +165,7 @@ END FUNCTION obj_isSquare END INTERFACE isSquare !---------------------------------------------------------------------------- -! isRectangle +! isRectangle !---------------------------------------------------------------------------- INTERFACE isRectangle @@ -176,7 +176,7 @@ END FUNCTION obj_isRectangle END INTERFACE isRectangle !---------------------------------------------------------------------------- -! GetColNumber +! GetColNumber !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. From 872bdbf1f21cd94847e7c3faf4b92bfd96e2b359 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 12:44:55 +0900 Subject: [PATCH 130/184] Updating ConvertUtility --- src/modules/Utility/src/ConvertUtility.F90 | 88 ++++++++++++------- .../Utility/src/ConvertUtility@Methods.F90 | 45 ++++++---- 2 files changed, 84 insertions(+), 49 deletions(-) diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90 index 2037e78d7..5ad52590a 100644 --- a/src/modules/Utility/src/ConvertUtility.F90 +++ b/src/modules/Utility/src/ConvertUtility.F90 @@ -50,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_Convert_1(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_Convert_1 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_Convert1_(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_Convert1_ +END INTERFACE Convert_ + !---------------------------------------------------------------------------- ! Convert@ConvertMethods !---------------------------------------------------------------------------- @@ -87,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 !---------------------------------------------------------------------------- @@ -111,20 +135,20 @@ 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_Convert_2(from, to) + REAL(DFP), INTENT(IN) :: from(:, :, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :) + END SUBROUTINE obj_Convert_2 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -136,11 +160,11 @@ END SUBROUTINE convert_2 ! summary: convert without allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE convert2_(From, To, nrow, ncol) - REAL(DFP), INTENT(IN) :: From(:, :, :, :) - REAL(DFP), INTENT(INOUT) :: To(:, :) + MODULE PURE SUBROUTINE obj_Convert2_(from, to, nrow, ncol) + REAL(DFP), INTENT(IN) :: from(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: to(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE convert2_ + END SUBROUTINE obj_Convert2_ END INTERFACE Convert_ !---------------------------------------------------------------------------- @@ -153,12 +177,12 @@ END SUBROUTINE convert2_ ! INTERFACE Convert - MODULE PURE SUBROUTINE convert_3(From, To) - REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :) + MODULE PURE SUBROUTINE obj_Convert_3(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_Convert_3 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -170,11 +194,11 @@ END SUBROUTINE convert_3 ! summary: convert without allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE convert3_(From, To, dim1, dim2, dim3, dim4) - REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :) - REAL(DFP), INTENT(INOUT) :: To(:, :, :, :) + MODULE PURE SUBROUTINE obj_Convert3_(from, to, dim1, dim2, dim3, dim4) + REAL(DFP), INTENT(IN) :: from(:, :, :, :, :, :) + REAL(DFP), INTENT(INOUT) :: to(:, :, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 - END SUBROUTINE convert3_ + END SUBROUTINE obj_Convert3_ END INTERFACE Convert_ !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90 index 20e817b35..2bedb8da4 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_Convert_1 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_Convert_1 !---------------------------------------------------------------------------- ! ConvertSafe !---------------------------------------------------------------------------- -MODULE PROCEDURE convert_1_safe +MODULE PROCEDURE obj_Convert1_ +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_Convert1_ + +!---------------------------------------------------------------------------- +! 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_Convert_2 ! Define internal variables INTEGER(I4B) :: a, b, I(4), r1, r2, c1, c2 I = SHAPE(From) @@ -94,13 +105,13 @@ To(r1:r2, c1:c2) = From(:, :, a, b) END DO END DO -END PROCEDURE convert_2 +END PROCEDURE obj_Convert_2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE convert2_ +MODULE PROCEDURE obj_Convert2_ INTEGER(I4B) :: a, b, r1, r2, c1, c2 INTEGER(I4B) :: dim1, dim2, dim3, dim4 @@ -123,13 +134,13 @@ END DO END DO -END PROCEDURE convert2_ +END PROCEDURE obj_Convert2_ !---------------------------------------------------------------------------- ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE convert_3 +MODULE PROCEDURE obj_Convert_3 INTEGER(I4B) :: a, b, s(6) REAL(DFP), ALLOCATABLE :: m2(:, :) !! @@ -143,13 +154,13 @@ END DO END DO DEALLOCATE (m2) -END PROCEDURE convert_3 +END PROCEDURE obj_Convert_3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE convert3_ +MODULE PROCEDURE obj_Convert3_ INTEGER(I4B) :: a, b INTEGER(I4B) :: n1, n2, n3, n4, n5, n6 @@ -171,7 +182,7 @@ END DO END DO -END PROCEDURE convert3_ +END PROCEDURE obj_Convert3_ !---------------------------------------------------------------------------- ! From a26a0e82ed6247ac28cc866cb462252ba8262f2e Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 12:45:05 +0900 Subject: [PATCH 131/184] Updating CSRMatrixAddMatrix --- .../CSRMatrix/src/CSRMatrix_AddMethods.F90 | 292 ++++++++++++++++++ .../src/CSRMatrix_AddMethods@Methods.F90 | 203 ++++++++++-- 2 files changed, 474 insertions(+), 21 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 index 0264c613f..247de10fd 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 @@ -91,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 @@ -109,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 @@ -125,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 !---------------------------------------------------------------------------- @@ -151,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 !---------------------------------------------------------------------------- @@ -180,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 !---------------------------------------------------------------------------- @@ -201,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 @@ -228,6 +319,25 @@ 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 !---------------------------------------------------------------------------- @@ -278,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 !---------------------------------------------------------------------------- @@ -308,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 !---------------------------------------------------------------------------- @@ -358,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 !---------------------------------------------------------------------------- @@ -390,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 !---------------------------------------------------------------------------- @@ -420,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 !---------------------------------------------------------------------------- @@ -458,6 +655,39 @@ 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_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 + 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_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) @@ -480,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 !---------------------------------------------------------------------------- @@ -510,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 !---------------------------------------------------------------------------- @@ -538,6 +826,10 @@ 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 index e8f5c344f..a36bcf6c0 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 @@ -21,8 +21,9 @@ SUBMODULE(CSRMatrix_AddMethods) Methods USE GlobalData, ONLY: FMT_NODES, FMT_DOF, NodesToDOF, DofToNodes -USE DOF_Method, ONLY: GetIndex, GetNodeLoc, OPERATOR(.tdof.) -USE ConvertUtility, ONLY: Convert +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 @@ -108,6 +109,17 @@ 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 !---------------------------------------------------------------------------- @@ -140,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 !---------------------------------------------------------------------------- @@ -168,13 +215,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Add4 +INTEGER(I4B) :: irow, icolumn -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) - +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 !---------------------------------------------------------------------------- @@ -196,6 +241,17 @@ 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 !---------------------------------------------------------------------------- @@ -212,17 +268,32 @@ 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 !---------------------------------------------------------------------------- @@ -241,18 +312,31 @@ 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 !---------------------------------------------------------------------------- @@ -270,6 +354,20 @@ 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 !---------------------------------------------------------------------------- @@ -285,6 +383,19 @@ 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 !---------------------------------------------------------------------------- @@ -308,6 +419,23 @@ ! 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(:) @@ -322,6 +450,22 @@ 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 !---------------------------------------------------------------------------- @@ -344,6 +488,23 @@ ! 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()" From c35ca91f337f5c7d638f87d24764eba0399a46b4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 12:47:35 +0900 Subject: [PATCH 132/184] Updating CSRMatrix_AddMethods making add_ public --- src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 index 247de10fd..8a98e7b39 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 @@ -20,7 +20,7 @@ MODULE CSRMatrix_AddMethods IMPLICIT NONE PRIVATE -PUBLIC :: Add +PUBLIC :: Add, Add_ PUBLIC :: AddToSTMatrix !---------------------------------------------------------------------------- From 99baca3fb7f168901e301769177daa09c19d1fa1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 20 Nov 2025 12:47:53 +0900 Subject: [PATCH 133/184] Formatting Convert changing the names --- src/modules/Utility/src/ConvertUtility.F90 | 24 +++++++++---------- .../Utility/src/ConvertUtility@Methods.F90 | 24 +++++++++---------- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90 index 5ad52590a..bcb54a384 100644 --- a/src/modules/Utility/src/ConvertUtility.F90 +++ b/src/modules/Utility/src/ConvertUtility.F90 @@ -50,7 +50,7 @@ MODULE ConvertUtility !@endnote INTERFACE Convert - MODULE PURE SUBROUTINE obj_Convert_1(from, to, conversion, nns, tdof) + 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(:, :) @@ -58,7 +58,7 @@ MODULE PURE SUBROUTINE obj_Convert_1(from, to, conversion, nns, tdof) INTEGER(I4B), INTENT(IN) :: conversion !! `conversion` can be `NodestoDOF` or `DOFtoNodes` INTEGER(I4B), INTENT(IN) :: nns, tdof - END SUBROUTINE obj_Convert_1 + END SUBROUTINE obj_Convert1 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -70,7 +70,7 @@ END SUBROUTINE obj_Convert_1 ! summary: Like Convert_1, but no allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE obj_Convert1_(from, to, conversion, nns, tdof, nrow, & + MODULE PURE SUBROUTINE obj_Convert_1(from, to, conversion, nns, tdof, nrow, & ncol) REAL(DFP), INTENT(IN) :: from(:, :) !! Matrix in one format @@ -82,7 +82,7 @@ MODULE PURE SUBROUTINE obj_Convert1_(from, to, conversion, nns, tdof, nrow, & !! number of nodes in space and tdod INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of data written in to - END SUBROUTINE obj_Convert1_ + END SUBROUTINE obj_Convert_1 END INTERFACE Convert_ !---------------------------------------------------------------------------- @@ -145,10 +145,10 @@ END SUBROUTINE obj_ConvertSafe1 ! Contains the block matrix structure in 2D. INTERFACE Convert - MODULE PURE SUBROUTINE obj_Convert_2(from, to) + MODULE PURE SUBROUTINE obj_Convert2(from, to) REAL(DFP), INTENT(IN) :: from(:, :, :, :) REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :) - END SUBROUTINE obj_Convert_2 + END SUBROUTINE obj_Convert2 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -160,11 +160,11 @@ END SUBROUTINE obj_Convert_2 ! summary: convert without allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE obj_Convert2_(from, to, nrow, ncol) + 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_Convert2_ + END SUBROUTINE obj_Convert_2 END INTERFACE Convert_ !---------------------------------------------------------------------------- @@ -177,12 +177,12 @@ END SUBROUTINE obj_Convert2_ ! INTERFACE Convert - MODULE PURE SUBROUTINE obj_Convert_3(from, to) + MODULE PURE SUBROUTINE obj_Convert3(from, to) REAL(DFP), INTENT(IN) :: from(:, :, :, :, :, :) !! I, J, ii, jj, a, b REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :, :, :) !! I, J, a, b - END SUBROUTINE obj_Convert_3 + END SUBROUTINE obj_Convert3 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -194,11 +194,11 @@ END SUBROUTINE obj_Convert_3 ! summary: convert without allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE obj_Convert3_(from, to, dim1, dim2, dim3, dim4) + 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_Convert3_ + END SUBROUTINE obj_Convert_3 END INTERFACE Convert_ !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90 index 2bedb8da4..92e4596ee 100644 --- a/src/submodules/Utility/src/ConvertUtility@Methods.F90 +++ b/src/submodules/Utility/src/ConvertUtility@Methods.F90 @@ -29,22 +29,22 @@ ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_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 obj_Convert_1 +END PROCEDURE obj_Convert1 !---------------------------------------------------------------------------- ! ConvertSafe !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_Convert1_ +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_Convert1_ +END PROCEDURE obj_Convert_1 !---------------------------------------------------------------------------- ! ConvertSafe @@ -89,7 +89,7 @@ ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_Convert_2 +MODULE PROCEDURE obj_Convert2 ! Define internal variables INTEGER(I4B) :: a, b, I(4), r1, r2, c1, c2 I = SHAPE(From) @@ -105,13 +105,13 @@ To(r1:r2, c1:c2) = From(:, :, a, b) END DO END DO -END PROCEDURE obj_Convert_2 +END PROCEDURE obj_Convert2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_Convert2_ +MODULE PROCEDURE obj_Convert_2 INTEGER(I4B) :: a, b, r1, r2, c1, c2 INTEGER(I4B) :: dim1, dim2, dim3, dim4 @@ -134,13 +134,13 @@ END DO END DO -END PROCEDURE obj_Convert2_ +END PROCEDURE obj_Convert_2 !---------------------------------------------------------------------------- ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_Convert_3 +MODULE PROCEDURE obj_Convert3 INTEGER(I4B) :: a, b, s(6) REAL(DFP), ALLOCATABLE :: m2(:, :) !! @@ -154,13 +154,13 @@ END DO END DO DEALLOCATE (m2) -END PROCEDURE obj_Convert_3 +END PROCEDURE obj_Convert3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_Convert3_ +MODULE PROCEDURE obj_Convert_3 INTEGER(I4B) :: a, b INTEGER(I4B) :: n1, n2, n3, n4, n5, n6 @@ -182,7 +182,7 @@ END DO END DO -END PROCEDURE obj_Convert3_ +END PROCEDURE obj_Convert_3 !---------------------------------------------------------------------------- ! From ef8128e32861d42b3c486b7ac02afdc5e41fed34 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 22 Nov 2025 21:17:37 +0900 Subject: [PATCH 134/184] Updating LineInterpolationUtility --- .../Line/src/LineInterpolationUtility.F90 | 219 +++++++++++++----- ...neInterpolationUtility@LagrangeMethods.F90 | 84 +++---- .../OrthogonalPolynomialUtility@Methods.F90 | 15 ++ 3 files changed, 213 insertions(+), 105 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index bb8e0f659..3280b5275 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -1022,8 +1022,9 @@ END SUBROUTINE LagrangeEvalAll_Line3_ ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeGradientEvalAll_Line - MODULE FUNCTION LagrangeGradientEvalAll_Line1(order, x, xij, coeff, & - firstCall, basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeGradientEvalAll_Line1( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1040,12 +1041,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Line1(order, x, xij, coeff, & !! If firstCall is False, then coeff will be used !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1062,10 +1058,10 @@ END FUNCTION LagrangeGradientEvalAll_Line1 END INTERFACE LagrangeGradientEvalAll_Line !---------------------------------------------------------------------------- -! +! LagrangeGradientEvalAll_Line_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeGradientEvalAll_Line_ +INTERFACE MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_( & order, x, xij, ans, dim1, dim2, dim3, coeff, firstCall, basisType, & alpha, beta, lambda) @@ -1101,6 +1097,59 @@ MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_( & 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_ !---------------------------------------------------------------------------- @@ -1273,9 +1322,9 @@ END FUNCTION OrthogonalBasis_Line1 ! OrthogonalBasis_Line_ !---------------------------------------------------------------------------- -INTERFACE OrthogonalBasis_Line_ - MODULE SUBROUTINE OrthogonalBasis_Line1_(order, xij, refLine, basisType, & - ans, nrow, ncol, alpha, beta, lambda) +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(:, :) @@ -1301,6 +1350,10 @@ MODULE SUBROUTINE OrthogonalBasis_Line1_(order, xij, refLine, basisType, & !! nrow = size(xij, 2) !! ncol = order+1 END SUBROUTINE OrthogonalBasis_Line1_ +END INTERFACE + +INTERFACE OrthogonalBasis_Line_ + MODULE PROCEDURE OrthogonalBasis_Line1_ END INTERFACE OrthogonalBasis_Line_ !---------------------------------------------------------------------------- @@ -1311,7 +1364,7 @@ END SUBROUTINE OrthogonalBasis_Line1_ ! date: 2023-06-23 ! summary: Evaluate basis functions of order upto n -INTERFACE OrthogonalBasisGradient_Line +INTERFACE MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -1320,15 +1373,9 @@ MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & !! point of evaluation !! Number of rows in xij is 1 CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT ! BIUNIT INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + ! basisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1340,6 +1387,10 @@ MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & !! 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 !---------------------------------------------------------------------------- @@ -1349,25 +1400,26 @@ END FUNCTION OrthogonalBasisGradient_Line1 !> 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 OrthogonalBasisGradient_Line_ - MODULE SUBROUTINE OrthogonalBasisGradient_Line1_(order, xij, refLine, & - basisType, ans, dim1, dim2, dim3, alpha, beta, lambda) +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 - !! UNIT - !! BIUNIT + !! reference line element: UNIT, BIUNIT INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! basisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1380,10 +1432,12 @@ MODULE SUBROUTINE OrthogonalBasisGradient_Line1_(order, xij, refLine, & !! 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 + !! 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_ !---------------------------------------------------------------------------- @@ -1394,7 +1448,7 @@ END SUBROUTINE OrthogonalBasisGradient_Line1_ ! date: 27 Oct 2022 ! summary: Evaluate all modal basis (heirarchical polynomial) on Line -INTERFACE HeirarchicalBasis_Line +INTERFACE MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation @@ -1408,15 +1462,19 @@ MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) 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 HeirarchicalBasis_Line_ - MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, & - nrow, ncol) +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(:, :) @@ -1431,15 +1489,19 @@ MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, & 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 HeirarchicalBasis_Line_ - MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, & - ans, nrow, ncol) +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(:, :) @@ -1456,6 +1518,10 @@ MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, & 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_ !---------------------------------------------------------------------------- @@ -1466,7 +1532,7 @@ END SUBROUTINE HeirarchicalBasis_Line2_ ! date: 27 Oct 2022 ! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line -INTERFACE HeirarchicalBasisGradient_Line +INTERFACE MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -1482,15 +1548,19 @@ MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) & 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 HeirarchicalBasisGradient_Line_ - MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, & - ans, dim1, dim2, dim3) +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(:, :) @@ -1506,15 +1576,19 @@ MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, & 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 HeirarchicalBasisGradient_Line - MODULE FUNCTION HeirarchicalGradientBasis_Line2(order, xij, refLine, & - orient) RESULT(ans) +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(:, :) @@ -1531,13 +1605,17 @@ MODULE FUNCTION HeirarchicalGradientBasis_Line2(order, xij, refLine, & !! 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 HeirarchicalBasisGradient_Line_ +INTERFACE MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_( & order, xij, refLine, orient, ans, dim1, dim2, dim3) INTEGER(I4B), INTENT(IN) :: order @@ -1557,6 +1635,10 @@ MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_( & 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_ !---------------------------------------------------------------------------- @@ -1567,9 +1649,9 @@ END SUBROUTINE HeirarchicalGradientBasis_Line2_ ! 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) +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 @@ -1588,15 +1670,19 @@ MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, & 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 BasisGradientEvalAll_Line_ - MODULE SUBROUTINE BasisGradientEvalAll_Line1_(order, x, refLine, & - basisType, alpha, beta, lambda, ans, tsize) +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 @@ -1618,6 +1704,10 @@ MODULE SUBROUTINE BasisGradientEvalAll_Line1_(order, x, refLine, & 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_ !---------------------------------------------------------------------------- @@ -1628,9 +1718,9 @@ END SUBROUTINE BasisGradientEvalAll_Line1_ ! 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) +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(:) @@ -1651,6 +1741,10 @@ MODULE FUNCTION BasisGradientEvalAll_Line2(order, x, refLine, basisType, & !! 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 !---------------------------------------------------------------------------- @@ -1658,9 +1752,8 @@ END FUNCTION BasisGradientEvalAll_Line2 !---------------------------------------------------------------------------- INTERFACE BasisGradientEvalAll_Line_ - MODULE SUBROUTINE BasisGradientEvalAll_Line2_(order, x, ans, nrow, ncol, & - refLine, basisType, alpha, beta, lambda) - + 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(:) diff --git a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 index 834722597..7b2f5aa01 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 @@ -388,62 +388,62 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeGradientEvalAll_Line1_ -#ifdef DEBUG_VER -CHARACTER(*), PARAMETER :: myName = "LagrangeGradientEvalAll_Line1_()" -LOGICAL(LGT) :: isok -#endif - -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1), areal -INTEGER(I4B) :: ii, orthopol0, indx(2), jj - -dim1 = SIZE(x, 2) -dim2 = SIZE(xij, 2) -dim3 = 1 +LOGICAL(LGT) :: firstCall0, iscoeff +REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1) +INTEGER(I4B) :: basisType0 -orthopol0 = Input(default=polyopt%Monomial, option=basisType) firstCall0 = Input(default=.TRUE., option=firstCall) +basisType0 = Input(default=polyopt%Monomial, option=basisType) +iscoeff = PRESENT(coeff) -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=indx(1), ncol=indx(2)) - END IF - coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) +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 LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff0, nrow=indx(1), ncol=indx(2)) + + 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 -SELECT CASE (orthopol0) -CASE (polyopt%Monomial) +END PROCEDURE LagrangeGradientEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +MODULE PROCEDURE LagrangeGradientEvalAll_Line2_ #ifdef DEBUG_VER - isok = dim2 .EQ. order + 1 - CALL AssertError1(isok, myName, modName, __LINE__, & - "size(xij, 2) is not same as order+1") +CHARACTER(*), PARAMETER :: myName = "LagrangeGradientEvalAll_Line2_()" #endif - DO ii = 0, order - indx(1) = MAX(ii - 1_I4B, 0_I4B) - areal = REAL(ii, kind=DFP) - DO jj = 1, dim1 - xx(jj, ii + 1) = areal * (x(1, jj)**(indx(1))) - END DO - END DO +! coeff0(order + 1, order + 1) +! xx(SIZE(x, 2), order + 1) -CASE DEFAULT - CALL GradientEvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, & - ans=xx, nrow=dim1, ncol=dim2) +INTEGER(I4B) :: indx(2) -END SELECT +dim1 = SIZE(x, 2) !! nips +dim2 = SIZE(xij, 2) !! tdof +dim3 = 1 -CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx, B=coeff0) -END PROCEDURE LagrangeGradientEvalAll_Line1_ +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 diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 80e5bbae1..0e4429343 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -250,6 +250,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GradientEvalAllOrthopol_ +INTEGER(I4B) :: indx, ii, jj +REAL(DFP) :: areal + SELECT CASE (orthopol) CASE (poly%Jacobi) ! ans(1:nrow, 1:ncol) = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) @@ -278,6 +281,18 @@ 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_ From d40b6e11660ea93e774aee63aeb76b74ac2085b4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 08:54:30 +0900 Subject: [PATCH 135/184] Formatting in LineInterpolationUtility --- src/modules/Line/src/LineInterpolationUtility.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 index 3280b5275..5c63d33ab 100644 --- a/src/modules/Line/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -1365,8 +1365,8 @@ END SUBROUTINE OrthogonalBasis_Line1_ ! summary: Evaluate basis functions of order upto n INTERFACE - MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & - basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION OrthogonalBasisGradient_Line1( & + order, xij, refLine, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: xij(:, :) From 50677e4b2ea48d2dc4a45e1398aafd459f99caa5 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 09:03:51 +0900 Subject: [PATCH 136/184] Updating FEVariable_QuadratureVariable --- .../FEVariable_QuadratureVariableMethod.F90 | 46 +++++++++++++++++++ ...iable_QuadratureVariableMethod@Methods.F90 | 38 +++++++++++++-- 2 files changed, 79 insertions(+), 5 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 index a387b170a..616c3fb65 100644 --- a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 @@ -127,6 +127,29 @@ END FUNCTION Quadrature_Scalar_Time ! 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 @@ -170,6 +193,29 @@ END FUNCTION Quadrature_Scalar_SpaceTime2 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 index 195faf2db..c7a221449 100644 --- a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -17,7 +17,6 @@ SUBMODULE(FEVariable_QuadratureVariableMethod) Methods USE ReallocateUtility, ONLY: Reallocate - USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate IMPLICIT NONE @@ -84,6 +83,20 @@ ! 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) @@ -111,16 +124,31 @@ tsize = s(1) * s(2) -CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & - vartype=TypeFEVariableOpt%spacetime, & - rank=TypeFEVariableOpt%scalar, len=tsize, & - val=val) +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 From e2184e13ce7aa476a773c03e4688468ad2e1caa8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 12:17:37 +0900 Subject: [PATCH 137/184] Updating LineInterpolationUtility --- .../Line/src/LineInterpolationUtility@LagrangeMethods.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 index 7b2f5aa01..420153623 100644 --- a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 +++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 @@ -431,6 +431,9 @@ 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, & From daee9c9f9bc0ae6dc13733b495152b332995c69d Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 21:29:23 +0900 Subject: [PATCH 138/184] Minor formatting in FEVariable --- src/modules/FEVariable/src/FEVariable_Method.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index dea120835..a6dbabc49 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -15,7 +15,6 @@ ! along with this program. If not, see MODULE FEVariable_Method - USE FEVariable_AdditionMethod USE FEVariable_ConstructorMethod USE FEVariable_DivisionMethod @@ -33,5 +32,4 @@ MODULE FEVariable_Method USE FEVariable_VectorInterpolationMethod USE FEVariable_MatrixInterpolationMethod USE FEVariable_InterpolationMethod - END MODULE FEVariable_Method From 6face99b4561d05ea0bfc043ddeca66f4cccd0bc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 21:29:41 +0900 Subject: [PATCH 139/184] Updating FEVariable ScalarInterpolation --- .../FEVariable_ScalarInterpolationMethod.F90 | 35 ++++++++++++++++ ...able_ScalarInterpolationMethod@Methods.F90 | 42 ++++++++++++++++++- 2 files changed, 76 insertions(+), 1 deletion(-) diff --git a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 index 47edd3db7..a77d18f36 100644 --- a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 @@ -354,6 +354,41 @@ MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_3( & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 index 28a3dd0c2..97c1e39dd 100644 --- a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 @@ -17,6 +17,8 @@ ! SUBMODULE(FEVariable_ScalarInterpolationMethod) Methods +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableSpaceTime, TypeFEVariableTime IMPLICIT NONE CONTAINS @@ -266,7 +268,7 @@ END SUBROUTINE MasterGetInterpolation3_ END PROCEDURE ScalarSpaceTimeGetInterpolation_2 !---------------------------------------------------------------------------- -! GetInterpolation_ +! GetInterpolation_ !---------------------------------------------------------------------------- ! obj%defineon is nodal @@ -304,4 +306,42 @@ END SUBROUTINE MasterGetInterpolation3_ 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 From 067aab8024a3871a5e38d0c1bc1c8869318b6ec1 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 21:30:00 +0900 Subject: [PATCH 140/184] Updating FEVariable Updating VectorInterpolation --- .../FEVariable_VectorInterpolationMethod.F90 | 117 ++++++++++-------- ...able_VectorInterpolationMethod@Methods.F90 | 45 +++++++ 2 files changed, 107 insertions(+), 55 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 index 89477018f..efdbca984 100644 --- a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 @@ -40,11 +40,9 @@ MODULE FEVariable_VectorInterpolationMethod ! summary: Get interpolation of Vector, constant INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE VectorConstantGetInterpolation_1(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - ans, nrow, ncol) + 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 @@ -81,11 +79,8 @@ END SUBROUTINE VectorConstantGetInterpolation_1 ! 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) + 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 @@ -117,12 +112,9 @@ END SUBROUTINE VectorConstantGetInterpolation_2 ! summary: Get interpolation of Vector, constant INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE VectorConstantGetInterpolation_3(obj, rank, vartype, & - N, nns, spaceIndx, & - timeIndx, & - scale, & - addContribution, & - ans, tsize) + 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 @@ -154,11 +146,9 @@ END SUBROUTINE VectorConstantGetInterpolation_3 ! summary: Get interpolation of Vector, space INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_1(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - ans, nrow, ncol) + 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 @@ -190,11 +180,8 @@ END SUBROUTINE VectorSpaceGetInterpolation_1 ! summary: Get interpolation of Vector, space INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_2(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - timeIndx, ans) + 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 @@ -226,12 +213,9 @@ END SUBROUTINE VectorSpaceGetInterpolation_2 ! summary: Get interpolation of Vector, space INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_3(obj, rank, vartype, & - N, nns, spaceIndx, & - timeIndx, & - scale, & - addContribution, & - ans, tsize) + 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 @@ -263,14 +247,9 @@ END SUBROUTINE VectorSpaceGetInterpolation_3 ! 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) + 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 @@ -320,14 +299,9 @@ END SUBROUTINE VectorSpaceTimeGetInterpolation_1 ! 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) + 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 @@ -363,13 +337,9 @@ END SUBROUTINE VectorSpaceTimeGetInterpolation_2 ! 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) + 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 @@ -396,6 +366,43 @@ MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_3(obj, rank, & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 index 7ff0c1ff5..e2dfa8d19 100644 --- a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 @@ -17,6 +17,8 @@ ! SUBMODULE(FEVariable_VectorInterpolationMethod) Methods +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableTime, TypeFEVariableSpaceTime IMPLICIT NONE CONTAINS @@ -495,4 +497,47 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ 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 From 146dc2bc95f7a6eec0f5e5f3e6fe4c294ade5138 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 21:55:55 +0900 Subject: [PATCH 141/184] Updating ProductUtility adding r1r1r1 for OuterProd_ --- src/modules/Utility/src/ProductUtility.F90 | 25 +++++++++++++++++++ .../Utility/src/ProductUtility@Methods.F90 | 20 +++++++++++++++ 2 files changed, 45 insertions(+) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index 599f76a6c..a62b3f3f4 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -542,6 +542,31 @@ END FUNCTION OuterProd_r1r1r1 ! update: 2021-12-19 ! summary: a b c +INTERFACE + 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), 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@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c + INTERFACE OuterProd MODULE PURE FUNCTION OuterProd_r1r1r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index d11862d72..0f2b95714 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -350,6 +350,26 @@ ! !---------------------------------------------------------------------------- +! 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_r1r1r2 ans = OuterProd(OuterProd(a, b), c) END PROCEDURE OuterProd_r1r1r2 From b2943cf16e28201c3f0a1a96f2900603e0269e55 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 23 Nov 2025 22:03:57 +0900 Subject: [PATCH 142/184] Updating ProductUtility adding r2r1r1 outerprod_ --- src/modules/Utility/src/ProductUtility.F90 | 37 ++++++++++++++++--- .../Utility/src/ProductUtility@Methods.F90 | 21 +++++++++++ 2 files changed, 52 insertions(+), 6 deletions(-) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index a62b3f3f4..87a487453 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -776,19 +776,44 @@ END FUNCTION OuterProd_r1r4r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +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)) + 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_r2r1r1 END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_@PROD +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c + +INTERFACE + 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), 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_ + !---------------------------------------------------------------------------- ! OuterProd@PROD !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 0f2b95714..14d0efb6f 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -450,6 +450,27 @@ ! !---------------------------------------------------------------------------- +! 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 From 8f9673d2aac5ed3e91cd0b26772b418788fed488 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 07:46:07 +0900 Subject: [PATCH 143/184] Updating FEVariable Matrix Interpolation --- .../FEVariable_MatrixInterpolationMethod.F90 | 61 ++++++++++++++----- ...able_MatrixInterpolationMethod@Methods.F90 | 34 ++++++++++- 2 files changed, 78 insertions(+), 17 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 index 42de8f9de..d8a1955a7 100644 --- a/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 @@ -39,12 +39,9 @@ MODULE FEVariable_MatrixInterpolationMethod ! 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) + 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 @@ -76,11 +73,8 @@ END SUBROUTINE MatrixConstantGetInterpolation_1 ! summary: Get interpolation of Matrix, constant INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_2(obj, rank, vartype, & - N, nns, nips, & - scale, & - addContribution, & - timeIndx, ans) + 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 @@ -112,11 +106,9 @@ END SUBROUTINE MatrixConstantGetInterpolation_2 ! 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) + 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 @@ -378,6 +370,43 @@ MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_3(obj, rank, & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 index adebfe74c..c00dba2ee 100644 --- a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 @@ -16,6 +16,8 @@ ! along with this program. If not, see SUBMODULE(FEVariable_MatrixInterpolationMethod) Methods +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableTime, TypeFEVariableSpaceTime IMPLICIT NONE CONTAINS @@ -309,7 +311,7 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP -SELECT CASE (obj%defineon ) +SELECT CASE (obj%defineon) CASE (TypeFEVariableOpt%nodal) CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=scale, N=N, & @@ -532,6 +534,36 @@ END SUBROUTINE MasterGetInterpolationFromQuadrature3_ 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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 41e9eea66b713478c046790fb5bda732cc4ed7b8 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 07:46:24 +0900 Subject: [PATCH 144/184] Updating STForceVector WIP --- .../src/STForceVector_Method.F90 | 900 ++++++++++--- .../src/STForceVector_Method@Methods.F90 | 1169 ++++++++--------- .../src/{STFV_1.inc => include/STFV_1.F90} | 0 .../src/{STFV_10.inc => include/STFV_10.F90} | 0 .../src/{STFV_11.inc => include/STFV_11.F90} | 0 .../src/{STFV_12.inc => include/STFV_12.F90} | 0 .../src/{STFV_13.inc => include/STFV_13.F90} | 0 .../src/{STFV_14.inc => include/STFV_14.F90} | 0 .../src/{STFV_15.inc => include/STFV_15.F90} | 0 .../src/{STFV_16.inc => include/STFV_16.F90} | 0 .../src/{STFV_17.inc => include/STFV_17.F90} | 0 .../src/{STFV_18.inc => include/STFV_18.F90} | 0 .../src/{STFV_19.inc => include/STFV_19.F90} | 0 .../src/{STFV_2.inc => include/STFV_2.F90} | 0 .../src/{STFV_20.inc => include/STFV_20.F90} | 0 .../src/{STFV_21.inc => include/STFV_21.F90} | 0 .../src/{STFV_3.inc => include/STFV_3.F90} | 0 .../src/{STFV_4.inc => include/STFV_4.F90} | 0 .../src/{STFV_5.inc => include/STFV_5.F90} | 0 .../src/{STFV_6.inc => include/STFV_6.F90} | 0 .../src/{STFV_7.inc => include/STFV_7.F90} | 0 .../src/{STFV_8.inc => include/STFV_8.F90} | 0 .../src/{STFV_9.inc => include/STFV_9.F90} | 0 23 files changed, 1233 insertions(+), 836 deletions(-) rename src/submodules/STForceVector/src/{STFV_1.inc => include/STFV_1.F90} (100%) rename src/submodules/STForceVector/src/{STFV_10.inc => include/STFV_10.F90} (100%) rename src/submodules/STForceVector/src/{STFV_11.inc => include/STFV_11.F90} (100%) rename src/submodules/STForceVector/src/{STFV_12.inc => include/STFV_12.F90} (100%) rename src/submodules/STForceVector/src/{STFV_13.inc => include/STFV_13.F90} (100%) rename src/submodules/STForceVector/src/{STFV_14.inc => include/STFV_14.F90} (100%) rename src/submodules/STForceVector/src/{STFV_15.inc => include/STFV_15.F90} (100%) rename src/submodules/STForceVector/src/{STFV_16.inc => include/STFV_16.F90} (100%) rename src/submodules/STForceVector/src/{STFV_17.inc => include/STFV_17.F90} (100%) rename src/submodules/STForceVector/src/{STFV_18.inc => include/STFV_18.F90} (100%) rename src/submodules/STForceVector/src/{STFV_19.inc => include/STFV_19.F90} (100%) rename src/submodules/STForceVector/src/{STFV_2.inc => include/STFV_2.F90} (100%) rename src/submodules/STForceVector/src/{STFV_20.inc => include/STFV_20.F90} (100%) rename src/submodules/STForceVector/src/{STFV_21.inc => include/STFV_21.F90} (100%) rename src/submodules/STForceVector/src/{STFV_3.inc => include/STFV_3.F90} (100%) rename src/submodules/STForceVector/src/{STFV_4.inc => include/STFV_4.F90} (100%) rename src/submodules/STForceVector/src/{STFV_5.inc => include/STFV_5.F90} (100%) rename src/submodules/STForceVector/src/{STFV_6.inc => include/STFV_6.F90} (100%) rename src/submodules/STForceVector/src/{STFV_7.inc => include/STFV_7.F90} (100%) rename src/submodules/STForceVector/src/{STFV_8.inc => include/STFV_8.F90} (100%) rename src/submodules/STForceVector/src/{STFV_9.inc => include/STFV_9.F90} (100%) diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index ca9504944..7733791ed 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,36 @@ 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 !---------------------------------------------------------------------------- @@ -51,137 +73,275 @@ 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 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_ + +!---------------------------------------------------------------------------- +! 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 +351,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 +392,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 +683,44 @@ 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, 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 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: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_15( & + test, projecton, c, crank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projecton + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_15 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_15 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -380,22 +730,48 @@ 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, 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 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, projecton, c1, c1rank, c2, c2rank, ans, nrow, ncol) + 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 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_16 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_16 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -405,20 +781,20 @@ 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, 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 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 +806,244 @@ 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, projecton, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3) + 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 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + 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, 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 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, projecton, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4) + 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 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + 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, 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 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, projecton, c1, c1rank, c2, c2rank, c3, c3rank, ans, nrow, ncol) + 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 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + 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, 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 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, projecton, c1, c1rank, c2, c2rank, c3, c3rank, ans, & + dim1, dim2, dim3) + 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 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + 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, 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 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, projecton, c1, c1rank, c2, c2rank, c3, c3rank, ans, dim1, dim2, & + dim3, dim4) + 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 + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + 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/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 07fe9fb90..bd51dc61d 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -17,849 +17,730 @@ SUBMODULE(STForceVector_Method) Methods USE BaseMethod +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ +USE FEVariable_Method, ONLY: FEVariableSize => Size + 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" +#include "./include/STFV_1.F90" +#include "./include/STFV_2.F90" +#include "./include/STFV_3.F90" +#include "./include/STFV_4.F90" +#include "./include/STFV_5.F90" +#include "./include/STFV_6.F90" +#include "./include/STFV_7.F90" + +#include "./include/STFV_8.F90" +#include "./include/STFV_9.F90" +#include "./include/STFV_10.F90" +#include "./include/STFV_11.F90" +#include "./include/STFV_12.F90" +#include "./include/STFV_13.F90" +#include "./include/STFV_14.F90" + +#include "./include/STFV_15.F90" +#include "./include/STFV_16.F90" +#include "./include/STFV_17.F90" +#include "./include/STFV_18.F90" +#include "./include/STFV_19.F90" +#include "./include/STFV_20.F90" +#include "./include/STFV_21.F90" !---------------------------------------------------------------------------- ! 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, ans=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) +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 + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * test(ipt)%jt * & + test(ipt)%thickness(ips) * test(ipt)%wt + + CALL OuterProd_( & + a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=1.0_DFP, & + 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 !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_3 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, ans=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 PROCEDURE STForceVector_3 +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 +! 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, ans=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) +MODULE PROCEDURE obj_STForceVector_2 +REAL(DFP) :: realval +INTEGER(I4B) :: nipt, ipt, ips, i1, i2 + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., ans=realval) + + realval = 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=1.0_DFP, & + 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 !---------------------------------------------------------------------------- -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, ans=c1bar, val=c1) -CALL getInterpolation(obj=test, ans=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 PROCEDURE STForceVector_5 +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_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, ans=c1bar, val=c1) -CALL getInterpolation(obj=test, ans=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) +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 + +DO ipt = 1, nipt + + DO ips = 1, test(ipt)%nips + + CALL GetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, spaceIndx=ips, & + timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nns, scale=1.0_DFP, & + addContribution=.TRUE., 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=1.0_DFP, scale=realval, & + ans=ans, dim1=i1, dim2=i2, dim3=i3) + END DO - !! END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_6 +END PROCEDURE obj_STForceVector_3 !---------------------------------------------------------------------------- ! 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, ans=c1bar, val=c1) -CALL getInterpolation(obj=test, ans=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 PROCEDURE STForceVector_7 +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_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_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) = 0.0_DFP + +DO ipt = 1, nipt + + DO ips = 1, test(ipt)%nips + + CALL GetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, spaceIndx=ips, & + timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nns, scale=1.0_DFP, & + addContribution=.TRUE., 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=1.0_DFP, 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_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_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_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_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) = 0.0_DFP + +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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., 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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., 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=1.0_DFP, & + scale=realval, ans=ans, nrow=i1, ncol=i2) + + END DO +END DO +END PROCEDURE obj_STForceVector_5 !---------------------------------------------------------------------------- -! +! 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_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_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_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) = 0.0_DFP + +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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., 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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., 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=1.0_DFP, & + scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO +END DO +END PROCEDURE obj_STForceVector_6 !---------------------------------------------------------------------------- -! +! 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_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 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_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) = 0.0_DFP + +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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., 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)%nns, & + scale=1.0_DFP, addContribution=.TRUE., 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=1.0_DFP, & + scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4) + + END DO +END DO +END PROCEDURE obj_STForceVector_7 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_15 - !! - !! Define internal variable - !! +MODULE PROCEDURE obj_STForceVector15 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)) - !! + +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 - !! + END DO - !! + DEALLOCATE (realval, p1) - !! -END PROCEDURE STForceVector_15 +END PROCEDURE obj_STForceVector15 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_16 - !! - !! Define internal variable - !! +MODULE PROCEDURE obj_STForceVector16 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, ans=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! + +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) - !! - -END PROCEDURE STForceVector_16 +END PROCEDURE obj_STForceVector16 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_17 - !! +MODULE PROCEDURE obj_STForceVector17 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, ans=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! + +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)) + ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips, ipt), & + p1(:, :, ips, ipt)) END DO - !! END DO - !! DEALLOCATE (realval, p1, c2bar) - !! -END PROCEDURE STForceVector_17 +END PROCEDURE obj_STForceVector17 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_18 - !! - !! Define internal variable - !! +MODULE PROCEDURE obj_STForceVector18 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, ans=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! + +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)) + ans = ans + realval(ips) * OUTERPROD(c2bar(:, :, ips, ipt), & + p1(:, :, ips, ipt)) END DO - !! END DO - !! DEALLOCATE (realval, p1, c2bar) - !! -END PROCEDURE STForceVector_18 +END PROCEDURE obj_STForceVector18 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_19 - !! - !! Define internal variable - !! +MODULE PROCEDURE obj_STForceVector19 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, ans=c2bar, val=c2) CALL getInterpolation(obj=test, ans=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! + +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) - !! - !! + 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 - !! + END DO - !! + DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_19 +END PROCEDURE obj_STForceVector19 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_20 - !! +MODULE PROCEDURE obj_STForceVector20 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, ans=c2bar, val=c2) CALL getInterpolation(obj=test, ans=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(c3bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! + +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) - !! + * c2bar(:, ipt) + DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD(c3bar(:, ips, ipt), p1(:, :, ips, ipt)) + ans = ans + realval(ips) * OUTERPROD(c3bar(:, ips, ipt), & + p1(:, :, ips, ipt)) END DO - !! + END DO - !! + DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_20 +END PROCEDURE obj_STForceVector20 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_21 - !! - !! Define internal variable - !! +MODULE PROCEDURE obj_STForceVector21 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, ans=c2bar, val=c2) CALL getInterpolation(obj=test, ans=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(c3bar, 1), & - & SIZE(c3bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! + +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) - !! + c2bar(:, ipt) + DO ips = 1, SIZE(realval) - !! - ans = ans + realval(ips) * OUTERPROD( & - & c3bar(:, :, ips, ipt), & - & p1(:, :, ips, ipt)) - !! + ans = ans + realval(ips) * OUTERPROD(c3bar(:, :, ips, ipt), & + p1(:, :, ips, ipt)) END DO END DO - !! + DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_21 +END PROCEDURE obj_STForceVector21 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +MODULE PROCEDURE obj_STForceVector8 +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) + +END SELECT + +END PROCEDURE obj_STForceVector8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector9 +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) +END SELECT + +END PROCEDURE obj_STForceVector9 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector10 +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) + +END SELECT +END PROCEDURE obj_STForceVector10 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector11 +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) + +END SELECT +END PROCEDURE obj_STForceVector11 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector12 +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) + +END SELECT +END PROCEDURE obj_STForceVector12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector13 +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) +END SELECT +END PROCEDURE obj_STForceVector13 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector14 +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) +END SELECT +END PROCEDURE obj_STForceVector14 + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/STForceVector/src/STFV_1.inc b/src/submodules/STForceVector/src/include/STFV_1.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_1.inc rename to src/submodules/STForceVector/src/include/STFV_1.F90 diff --git a/src/submodules/STForceVector/src/STFV_10.inc b/src/submodules/STForceVector/src/include/STFV_10.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_10.inc rename to src/submodules/STForceVector/src/include/STFV_10.F90 diff --git a/src/submodules/STForceVector/src/STFV_11.inc b/src/submodules/STForceVector/src/include/STFV_11.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_11.inc rename to src/submodules/STForceVector/src/include/STFV_11.F90 diff --git a/src/submodules/STForceVector/src/STFV_12.inc b/src/submodules/STForceVector/src/include/STFV_12.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_12.inc rename to src/submodules/STForceVector/src/include/STFV_12.F90 diff --git a/src/submodules/STForceVector/src/STFV_13.inc b/src/submodules/STForceVector/src/include/STFV_13.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_13.inc rename to src/submodules/STForceVector/src/include/STFV_13.F90 diff --git a/src/submodules/STForceVector/src/STFV_14.inc b/src/submodules/STForceVector/src/include/STFV_14.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_14.inc rename to src/submodules/STForceVector/src/include/STFV_14.F90 diff --git a/src/submodules/STForceVector/src/STFV_15.inc b/src/submodules/STForceVector/src/include/STFV_15.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_15.inc rename to src/submodules/STForceVector/src/include/STFV_15.F90 diff --git a/src/submodules/STForceVector/src/STFV_16.inc b/src/submodules/STForceVector/src/include/STFV_16.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_16.inc rename to src/submodules/STForceVector/src/include/STFV_16.F90 diff --git a/src/submodules/STForceVector/src/STFV_17.inc b/src/submodules/STForceVector/src/include/STFV_17.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_17.inc rename to src/submodules/STForceVector/src/include/STFV_17.F90 diff --git a/src/submodules/STForceVector/src/STFV_18.inc b/src/submodules/STForceVector/src/include/STFV_18.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_18.inc rename to src/submodules/STForceVector/src/include/STFV_18.F90 diff --git a/src/submodules/STForceVector/src/STFV_19.inc b/src/submodules/STForceVector/src/include/STFV_19.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_19.inc rename to src/submodules/STForceVector/src/include/STFV_19.F90 diff --git a/src/submodules/STForceVector/src/STFV_2.inc b/src/submodules/STForceVector/src/include/STFV_2.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_2.inc rename to src/submodules/STForceVector/src/include/STFV_2.F90 diff --git a/src/submodules/STForceVector/src/STFV_20.inc b/src/submodules/STForceVector/src/include/STFV_20.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_20.inc rename to src/submodules/STForceVector/src/include/STFV_20.F90 diff --git a/src/submodules/STForceVector/src/STFV_21.inc b/src/submodules/STForceVector/src/include/STFV_21.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_21.inc rename to src/submodules/STForceVector/src/include/STFV_21.F90 diff --git a/src/submodules/STForceVector/src/STFV_3.inc b/src/submodules/STForceVector/src/include/STFV_3.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_3.inc rename to src/submodules/STForceVector/src/include/STFV_3.F90 diff --git a/src/submodules/STForceVector/src/STFV_4.inc b/src/submodules/STForceVector/src/include/STFV_4.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_4.inc rename to src/submodules/STForceVector/src/include/STFV_4.F90 diff --git a/src/submodules/STForceVector/src/STFV_5.inc b/src/submodules/STForceVector/src/include/STFV_5.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_5.inc rename to src/submodules/STForceVector/src/include/STFV_5.F90 diff --git a/src/submodules/STForceVector/src/STFV_6.inc b/src/submodules/STForceVector/src/include/STFV_6.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_6.inc rename to src/submodules/STForceVector/src/include/STFV_6.F90 diff --git a/src/submodules/STForceVector/src/STFV_7.inc b/src/submodules/STForceVector/src/include/STFV_7.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_7.inc rename to src/submodules/STForceVector/src/include/STFV_7.F90 diff --git a/src/submodules/STForceVector/src/STFV_8.inc b/src/submodules/STForceVector/src/include/STFV_8.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_8.inc rename to src/submodules/STForceVector/src/include/STFV_8.F90 diff --git a/src/submodules/STForceVector/src/STFV_9.inc b/src/submodules/STForceVector/src/include/STFV_9.F90 similarity index 100% rename from src/submodules/STForceVector/src/STFV_9.inc rename to src/submodules/STForceVector/src/include/STFV_9.F90 From 18bc3c3357100d1695c788eb294250b3370d5bad Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 08:04:46 +0900 Subject: [PATCH 145/184] Updating ElemshapeData GetProjection of dNdxt --- .../src/ElemshapeData_ProjectionMethods.F90 | 21 +++++------ ...lemshapeData_ProjectionMethods@Methods.F90 | 36 +++++++++---------- 2 files changed, 27 insertions(+), 30 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 0f71ae33b..59bfa3953 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -21,9 +21,10 @@ MODULE ElemshapeData_ProjectionMethods IMPLICIT NONE PRIVATE -PUBLIC :: getProjectionOfdNdXt -PUBLIC :: getProjectionOfdNdXt_ -PUBLIC :: getProjectionOfdNTdXt +PUBLIC :: GetProjectionOfdNdXt +PUBLIC :: GetProjectionOfdNdXt_ +PUBLIC :: GetProjectionOfdNTdXt + ! TODO: implement ! PUBLIC :: getProjectionOfdNTdXt_ @@ -44,13 +45,13 @@ MODULE ElemshapeData_ProjectionMethods ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val) + MODULE PURE SUBROUTINE GetProjectionOfdNdXt_1(obj, val, 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(:) !! 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 GetProjectionOfdNdXt !---------------------------------------------------------------------------- @@ -62,12 +63,12 @@ END SUBROUTINE getProjectionOfdNdXt_1 ! summary: get interpolation of vector without allocation INTERFACE GetProjectionOfdNdXt_ - MODULE PURE SUBROUTINE getProjectionOfdNdXt1_(obj, cdNdXt, val, nrow, ncol) + MODULE PURE SUBROUTINE GetProjectionOfdNdXt1_(obj, val, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE getProjectionOfdNdXt1_ + END SUBROUTINE GetProjectionOfdNdXt1_ END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index 15e24589b..4af341053 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -24,36 +24,32 @@ ! getProjectionOfdNdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt_1 - !! 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)) -END DO - !! -END PROCEDURE getProjectionOfdNdXt_1 +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, val=val, nrow=nrow, & + ncol=ncol) +END PROCEDURE GetProjectionOfdNdXt_1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt1_ +MODULE PROCEDURE GetProjectionOfdNdXt1_ INTEGER(I4B) :: ii, nsd -nrow = SIZE(obj%dNdXt, 1) -ncol = SIZE(obj%dNdXt, 3) -nsd = SIZE(obj%dNdXt, 2) +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 - cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), Val(1:nsd)) + ans(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), val(1:nsd)) END DO - -END PROCEDURE getProjectionOfdNdXt1_ +END PROCEDURE GetProjectionOfdNdXt1_ !---------------------------------------------------------------------------- ! getProjectionOfdNdXt From 9317bb5bf0741363b3b27ca8101ea78a7bb4ff70 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 08:24:30 +0900 Subject: [PATCH 146/184] Updating ElemshapeData Updating interface of GetProjection --- .../src/ElemshapeData_ProjectionMethods.F90 | 62 ++++++++++++------ .../src/STForceVector_Method.F90 | 5 +- src/submodules/ConvectiveMatrix/src/CM_1.inc | 2 +- src/submodules/ConvectiveMatrix/src/CM_2.inc | 2 +- .../src/ConvectiveMatrix_Method@Methods.F90 | 8 ++- .../src/DiffusionMatrix_Method@Methods.F90 | 55 ++++++++++------ ...ElemshapeData_HRGNParamMethods@Methods.F90 | 3 +- ...lemshapeData_ProjectionMethods@Methods.F90 | 64 ++++++++----------- ...apeData_StabilizationParamMethods@SUPG.F90 | 10 +-- .../src/STForceVector_Method@Methods.F90 | 64 +++++++++++++++---- 10 files changed, 172 insertions(+), 103 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 59bfa3953..7a1df269e 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -29,7 +29,7 @@ MODULE ElemshapeData_ProjectionMethods ! PUBLIC :: getProjectionOfdNTdXt_ !---------------------------------------------------------------------------- -! getProjectionOfdNdXt@ProjectionMethods +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -44,35 +44,43 @@ MODULE ElemshapeData_ProjectionMethods ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE GetProjectionOfdNdXt_1(obj, val, ans) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt_1(obj, c, ans) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), INTENT(IN) :: c(:) !! constant value of vector 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 !---------------------------------------------------------------------------- -! +! GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- !> author: Shion Shimizu ! date: 2025-03-05 ! summary: get interpolation of vector without allocation -INTERFACE GetProjectionOfdNdXt_ - MODULE PURE SUBROUTINE GetProjectionOfdNdXt1_(obj, val, ans, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt1_(obj, c, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:) + 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@getMethod +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -87,28 +95,40 @@ END SUBROUTINE GetProjectionOfdNdXt1_ ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val) +INTERFACE + 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 GetProjectionOfdNdXt_ - MODULE PURE SUBROUTINE getProjectionOfdNdXt2_(obj, cdNdXt, val, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt2_(obj, c, crank, ans, nrow, & + ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) - CLASS(FEVariable_), INTENT(IN) :: val + 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 SUBROUTINE GetProjectionOfdNdXt2_ +END INTERFACE + +INTERFACE GetProjectionOfdNdXt_ + MODULE PROCEDURE GetProjectionOfdNdXt2_ END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index 7733791ed..38a33ac78 100644 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -703,7 +703,10 @@ END FUNCTION obj_STForceVector15 !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 -! summary: Force vector +! summary: Space time force vector +! + + INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_15( & diff --git a/src/submodules/ConvectiveMatrix/src/CM_1.inc b/src/submodules/ConvectiveMatrix/src/CM_1.inc index b72de1350..3500b3885 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_1.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_1.inc @@ -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_2.inc b/src/submodules/ConvectiveMatrix/src/CM_2.inc index 345c2a243..a6fe2f259 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_2.inc +++ b/src/submodules/ConvectiveMatrix/src/CM_2.inc @@ -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/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 index 6eb09e54e..6c2dcb8aa 100644 --- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 +++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 @@ -195,8 +195,9 @@ PURE SUBROUTINE CM1_(ans, test, trial, c, term1, term2, opt, nrow, ncol) ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetProjectionOfdNdXt_(obj=trial, cdNdXt=p, val=c, nrow=ii, ncol=jj) - !! + 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), & @@ -235,7 +236,8 @@ PURE SUBROUTINE CM2_(ans, test, trial, c, term1, term2, opt, nrow, ncol) ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetProjectionOfdNdXt_(obj=test, cdNdXt=p, val=c, nrow=ii, ncol=jj) + 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) diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 index 659def2fb..e877c2974 100644 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -123,8 +123,10 @@ MODULE PROCEDURE DiffusionMatrix_3 REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +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) @@ -144,8 +146,10 @@ INTEGER(I4B) :: ii, jj, kk REAL(DFP), PARAMETER :: one = 1.0_DFP -CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=k, nrow=nrow, ncol=ii) -CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=k, nrow=ncol, ncol=ii) +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 @@ -271,11 +275,16 @@ MODULE PROCEDURE DiffusionMatrix_6 REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) -CALL getInterpolation(obj=trial, ans=realval, val=c1) + +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)) + +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 @@ -293,12 +302,11 @@ INTEGER(I4B) :: ii, jj, kk REAL(DFP), PARAMETER :: one = 1.0_DFP -CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=c2, & - nrow=nrow, ncol=ii) -CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=c2, & - nrow=ncol, ncol=ii) - -CALL getInterpolation_(obj=trial, ans=realval, val=c1, & +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 @@ -316,7 +324,6 @@ nrow = opt * nrow ncol = opt * ncol END IF - END PROCEDURE DiffusionMatrix6_ !---------------------------------------------------------------------------- @@ -364,8 +371,10 @@ 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) +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)) @@ -392,8 +401,10 @@ 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) +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) @@ -435,8 +446,10 @@ 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) +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) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 index 97ba604d5..1e6259bd7 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 !! diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index 4af341053..3dbacf835 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -21,7 +21,7 @@ CONTAINS !---------------------------------------------------------------------------- -! getProjectionOfdNdXt +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNdXt_1 @@ -31,12 +31,11 @@ ncol = obj%nips CALL Reallocate(ans, nrow, ncol) -CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, val=val, nrow=nrow, & - ncol=ncol) +CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, nrow=nrow, ncol=ncol) END PROCEDURE GetProjectionOfdNdXt_1 !---------------------------------------------------------------------------- -! +! GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNdXt1_ @@ -47,48 +46,41 @@ nsd = obj%nsd !!SIZE(obj%dNdXt, 2) DO ii = 1, ncol - ans(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), val(1:nsd)) + ans(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), c(1:nsd)) END DO END PROCEDURE GetProjectionOfdNdXt1_ !---------------------------------------------------------------------------- -! getProjectionOfdNdXt +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt_2 -INTEGER(I4B) :: ii, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, ans=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)) -END DO - !! -DEALLOCATE (cbar) - !! -END PROCEDURE getProjectionOfdNdXt_2 +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) :: ii, nsd -REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) - -CALL GetInterpolation_(obj=obj, val=val, ans=cbar, nrow=nrow, ncol=ncol) -nsd = nrow -nrow = SIZE(obj%dNdXt, 1) - -DO ii = 1, ncol - cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), cbar(1:nsd, ii)) -END DO - -END PROCEDURE getProjectionOfdNdXt2_ +MODULE PROCEDURE GetProjectionOfdNdXt2_ +! INTEGER(I4B) :: ii, nsd +! REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) +! +! CALL GetInterpolation_(obj=obj, val=val, ans=cbar, nrow=nrow, ncol=ncol) +! nsd = nrow +! nrow = SIZE(obj%dNdXt, 1) +! +! DO ii = 1, ncol +! cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), cbar(1:nsd, ii)) +! END DO +! +END PROCEDURE GetProjectionOfdNdXt2_ !---------------------------------------------------------------------------- ! getProjectionOfdNdXt diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 index d1e6fe30b..d228a77bb 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 @@ -70,11 +70,12 @@ 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, ans=nubar) !! @@ -350,11 +351,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 diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index bd51dc61d..53b39a118 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -73,6 +73,8 @@ nrow = test(1)%nns ncol = test(1)%nnt +ans(1:nrow, 1:ncol) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * test(ipt)%jt * & @@ -112,6 +114,8 @@ nrow = test(1)%nns ncol = test(1)%nnt +ans(1:nrow, 1:ncol) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -159,6 +163,8 @@ dim2 = test(1)%nns dim3 = test(1)%nnt +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -411,7 +417,7 @@ CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) -CALL reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) +CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) DO ipt = 1, SIZE(test) @@ -426,6 +432,36 @@ DEALLOCATE (realval, p1) END PROCEDURE obj_STForceVector15 +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_15 +REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) +INTEGER(I4B) :: ips, ipt, nipt + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) + +! CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) + +DO ipt = 1, nipt + + realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness + + DO ips = 1, test(ipt)%nips + ans = ans + realval(ips) * p1(:, :, ips, ipt) + END DO + +END DO + +DEALLOCATE (realval, p1) +END PROCEDURE obj_STForceVector_15 + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -439,7 +475,7 @@ CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) CALL getInterpolation(obj=test, ans=c2bar, val=c2) -CALL reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) +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) @@ -461,9 +497,9 @@ INTEGER(I4B) :: ips, ipt CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, ans=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -CALL reallocate(ans, SIZE(c2bar, 1), SIZE(test(1)%N, 1), SIZE(test(1)%T)) +CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test(1)%N, 1), SIZE(test(1)%T)) DO ipt = 1, SIZE(test) @@ -488,9 +524,9 @@ INTEGER(I4B) :: ips, ipt CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, ans=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -CALL reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test(1)%N, 1), & +CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test(1)%N, 1), & SIZE(test(1)%T)) DO ipt = 1, SIZE(test) @@ -515,8 +551,8 @@ INTEGER(I4B) :: ips, ipt CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, ans=c2bar, val=c2) -CALL getInterpolation(obj=test, ans=c3bar, val=c3) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c3bar, val=c3) CALL reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) @@ -545,10 +581,10 @@ INTEGER(I4B) :: ips, ipt CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, ans=c2bar, val=c2) -CALL getInterpolation(obj=test, ans=c3bar, val=c3) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c3bar, val=c3) -CALL reallocate(ans, SIZE(c3bar, 1), SIZE(test(1)%N, 1), SIZE(test(1)%T)) +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 & @@ -576,10 +612,10 @@ INTEGER(I4B) :: ips, ipt CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, ans=c2bar, val=c2) -CALL getInterpolation(obj=test, ans=c3bar, val=c3) +CALL GetInterpolation(obj=test, ans=c2bar, val=c2) +CALL GetInterpolation(obj=test, ans=c3bar, val=c3) -CALL reallocate(ans, SIZE(c3bar, 1), SIZE(c3bar, 2), SIZE(test(1)%N, 1), & +CALL Reallocate(ans, SIZE(c3bar, 1), SIZE(c3bar, 2), SIZE(test(1)%N, 1), & SIZE(test(1)%T)) DO ipt = 1, SIZE(test) From 1ce95bcd3e5a25e93ba06c7514e45d411accdfa4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 09:13:54 +0900 Subject: [PATCH 147/184] Updating ElemshapeData updating interface of GetProjection --- .../src/ElemshapeData_ProjectionMethods.F90 | 31 +++-- ...lemshapeData_ProjectionMethods@Methods.F90 | 109 ++++++++---------- ...acetMatrix_Method@FacetMatrix11Methods.F90 | 40 +++---- ...acetMatrix_Method@FacetMatrix12Methods.F90 | 16 +-- ...acetMatrix_Method@FacetMatrix13Methods.F90 | 20 ++-- ...acetMatrix_Method@FacetMatrix14Methods.F90 | 20 ++-- ...acetMatrix_Method@FacetMatrix15Methods.F90 | 48 ++++---- ...FacetMatrix_Method@FacetMatrix1Methods.F90 | 48 ++++---- ...acetMatrix_Method@FacetMatrix21Methods.F90 | 12 +- ...FacetMatrix_Method@FacetMatrix2Methods.F90 | 17 ++- ...FacetMatrix_Method@FacetMatrix3Methods.F90 | 20 ++-- ...FacetMatrix_Method@FacetMatrix4Methods.F90 | 20 ++-- ...FacetMatrix_Method@FacetMatrix5Methods.F90 | 48 ++++---- 13 files changed, 224 insertions(+), 225 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 7a1df269e..318aed7ed 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -147,15 +147,19 @@ END SUBROUTINE GetProjectionOfdNdXt2_ ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt_3(obj, c, ans) CLASS(ElemshapeData_), INTENT(IN) :: obj !! ElemshapeData object - 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(:, :) !! a vector, defined over quadrature points - END SUBROUTINE getProjectionOfdNdXt_3 + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNdXt_3 +END INTERFACE + +INTERFACE GetProjectionOfdNdXt + MODULE PROCEDURE GetProjectionOfdNdXt_3 END INTERFACE GetProjectionOfdNdXt !---------------------------------------------------------------------------- @@ -166,13 +170,18 @@ END SUBROUTINE getProjectionOfdNdXt_3 ! date: 2025-03-05 ! summary: get interpolation of vector without allocation -INTERFACE GetProjectionOfdNdXt_ - MODULE PURE SUBROUTINE getProjectionOfdNdXt3_(obj, cdNdXt, val, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt3_(obj, c, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) - REAL(DFP), INTENT(IN) :: val(:, :) + REAL(DFP), INTENT(IN) :: c(:, :) + !! a vector, defined over quadrature points + REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE getProjectionOfdNdXt3_ + END SUBROUTINE GetProjectionOfdNdXt3_ +END INTERFACE + +INTERFACE GetProjectionOfdNdXt_ + MODULE PROCEDURE GetProjectionOfdNdXt3_ END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index 3dbacf835..a766403e7 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -17,6 +17,8 @@ SUBMODULE(ElemshapeData_ProjectionMethods) Methods USE BaseMethod + +! USE FEVariable_Method, only: FEVariableGetInterpolation_ => GetInterpolation_ IMPLICIT NONE CONTAINS @@ -69,93 +71,88 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNdXt2_ -! INTEGER(I4B) :: ii, nsd +INTEGER(I4B) :: ips, nsd, i1 ! REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) -! -! CALL GetInterpolation_(obj=obj, val=val, ans=cbar, nrow=nrow, ncol=ncol) -! nsd = nrow -! nrow = SIZE(obj%dNdXt, 1) -! -! DO ii = 1, ncol -! cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), cbar(1:nsd, ii)) -! END DO -! +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 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)) -END DO - !! -END PROCEDURE getProjectionOfdNdXt_3 +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) :: ii, nsd +MODULE PROCEDURE GetProjectionOfdNdXt3_ +INTEGER(I4B) :: ips, nsd -nrow = SIZE(obj%dNdXt, 1) -ncol = SIZE(obj%dNdXt, 3) -nsd = SIZE(obj%dNdXt, 2) +nrow = obj%nns +ncol = obj%nips +nsd = obj%nsd -DO ii = 1, ncol - cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), val(1:nsd, ii)) +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 getProjectionOfdNdXt3_ +END PROCEDURE GetProjectionOfdNdXt3_ !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNTdXt_1 +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)) END DO - !! -END PROCEDURE getProjectionOfdNTdXt_1 +END PROCEDURE GetProjectionOfdNTdXt_1 !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt !---------------------------------------------------------------------------- MODULE PROCEDURE getProjectionOfdNTdXt_2 - !! INTEGER(I4B) :: ii, nsd REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! + CALL getInterpolation(obj=obj, val=val, ans=cbar) CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & - & SIZE(obj%dNTdXt, 4)) + 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)) END DO - !! + DEALLOCATE (cbar) END PROCEDURE getProjectionOfdNTdXt_2 @@ -164,40 +161,36 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE getProjectionOfdNTdXt_3 - !! INTEGER(I4B) :: ii, jj, nsd REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - !! - !! main - !! + CALL getInterpolation(obj=obj, val=val, ans=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 DO END DO - !! + DEALLOCATE (cbar) - !! END PROCEDURE getProjectionOfdNTdXt_3 !---------------------------------------------------------------------------- diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 index 2fc69ccf0..3c6252ec0 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 @@ -38,13 +38,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP !! @@ -89,13 +89,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = masterC1 * muMaster slaveC1 = slaveC1 * muSlave @@ -141,13 +141,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! @@ -194,13 +194,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) !! @@ -248,13 +248,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 index 7828f15f9..7ea38ee45 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 @@ -35,8 +35,8 @@ CALL Reallocate(ans, nns, nns) CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal) + & ans=C1, & + & c=elemsd%normal) realval = elemsd%js * elemsd%ws * elemsd%thickness DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -62,8 +62,8 @@ CALL Reallocate(ans, nns, nns) CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal) + & ans=C1, & + & c=elemsd%normal) realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -89,8 +89,8 @@ CALL Reallocate(ans, nns, nns) CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal) + & 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 @@ -115,7 +115,7 @@ 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 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 @@ -141,7 +141,7 @@ 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 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 diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 index 7c8d55afe..79953118f 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 @@ -47,8 +47,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness !! @@ -96,8 +96,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -145,8 +145,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! @@ -196,8 +196,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) !! @@ -247,8 +247,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 index 711f6c78b..e83caaab5 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 @@ -44,8 +44,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! @@ -94,8 +94,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -142,8 +142,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! !! CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) @@ -193,8 +193,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) !! @@ -243,8 +243,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 index a4dec8f4f..4a69f9768 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 @@ -51,13 +51,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! DO ips = 1, nips slaveips = quadMap(ips) @@ -120,13 +120,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -192,13 +192,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -269,13 +269,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL getInterpolation( & & obj=masterElemSD, & @@ -350,13 +350,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL getInterpolation( & & obj=masterElemSD, & @@ -437,13 +437,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL getInterpolation( & & obj=masterElemSD, & diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 index e936db88f..3636a0eec 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 @@ -35,15 +35,15 @@ nips = SIZE(masterElemSD%dNdXt, 3) nns2 = SIZE(slaveElemSD%dNdXt, 1) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! i3 = eye(nsd) !! @@ -101,15 +101,15 @@ nips = SIZE(masterElemSD%dNdXt, 3) nns2 = SIZE(slaveElemSD%dNdXt, 1) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! i3 = eye(nsd) !! @@ -170,13 +170,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! @@ -240,13 +240,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, & val=muMaster) @@ -313,13 +313,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, & val=muMaster) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 index a354399bc..b0a7cc320 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 @@ -35,8 +35,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! ALLOCATE (ans(nns1, nns2)) ans = 0.0_DFP @@ -72,8 +72,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar !! @@ -106,8 +106,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 index 5cc57ee29..6ccf5d388 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 @@ -34,10 +34,7 @@ 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) @@ -84,8 +81,8 @@ 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) @@ -132,8 +129,8 @@ 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, ans=taubar, val=tauvar) !! @@ -182,7 +179,7 @@ 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, ans=muBar, val=mu) !! CALL Reallocate(G12, nns1, nsd, nsd) @@ -231,7 +228,7 @@ 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, ans=muBar, val=mu) CALL GetInterpolation(obj=elemsd, ans=tauBar, val=tauvar) !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 index 5d9eae67c..32deda6dc 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 @@ -49,8 +49,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness !! @@ -107,8 +107,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -165,8 +165,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! @@ -225,8 +225,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) !! @@ -287,8 +287,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 index fd03adb8d..2a3877858 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 @@ -49,8 +49,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness !! @@ -109,8 +109,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -169,8 +169,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! @@ -231,8 +231,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) !! @@ -293,8 +293,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 index 89943f008..1e66637a7 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 @@ -55,13 +55,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! DO ips = 1, nips !! @@ -139,13 +139,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -226,13 +226,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -315,13 +315,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) !! @@ -411,13 +411,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=tauMasterBar, val=tauMaster) !! @@ -508,13 +508,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) !! From a28fba19728b0f9e6a52e250f3a0a7c5cea55024 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 11:49:18 +0900 Subject: [PATCH 148/184] Updating ElemshapeData updating interface of getProjection --- .../src/ElemshapeData_ProjectionMethods.F90 | 54 +++++--- ...ElemshapeData_HRGNParamMethods@Methods.F90 | 3 +- ...lemshapeData_ProjectionMethods@Methods.F90 | 118 +++++++++--------- ...apeData_StabilizationParamMethods@SUPG.F90 | 11 +- .../STConvectiveMatrix/src/STCM_1.inc | 6 +- .../STConvectiveMatrix/src/STCM_10.inc | 6 +- .../STConvectiveMatrix/src/STCM_11.inc | 12 +- .../STConvectiveMatrix/src/STCM_12.inc | 6 +- .../STConvectiveMatrix/src/STCM_17.inc | 12 +- .../STConvectiveMatrix/src/STCM_6.inc | 6 +- .../STConvectiveMatrix/src/STCM_7.inc | 12 +- .../STConvectiveMatrix/src/STCM_8.inc | 8 +- .../STConvectiveMatrix/src/STCM_9.inc | 5 +- .../src/STDiffusionMatrix_Method@Methods.F90 | 18 ++- .../src/STForceVector_Method@Methods.F90 | 24 ++-- 15 files changed, 178 insertions(+), 123 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 318aed7ed..6dbebe606 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -198,14 +198,18 @@ END SUBROUTINE GetProjectionOfdNdXt3_ ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -INTERFACE GetProjectionOfdNTdXt - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_1(obj, c, ans) CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :) - !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ - REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), INTENT(IN) :: c(:) !! constant value of vector - END SUBROUTINE getProjectionOfdNTdXt_1 + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNTdXt_1 +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt + MODULE PROCEDURE GetProjectionOfdNdXt_1 END INTERFACE GetProjectionOfdNTdXt !---------------------------------------------------------------------------- @@ -227,19 +231,24 @@ 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 GetProjectionOfdNTdXt - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val) + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_2(obj, c, crank, ans) CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :) - !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ - TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_), INTENT(IN) :: c !! constant value of vector - END SUBROUTINE getProjectionOfdNTdXt_2 + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNTdXt_2 +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt + MODULE PROCEDURE GetProjectionOfdNTdXt_2 END INTERFACE GetProjectionOfdNTdXt !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt@getMethod +! GetProjectionOfdNTdXt@getMethod !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -258,13 +267,18 @@ 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 GetProjectionOfdNTdXt - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val) + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_3(obj, c, crank, ans) 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), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + END SUBROUTINE GetProjectionOfdNTdXt_3 +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt + MODULE PROCEDURE GetProjectionOfdNTdXt_3 END INTERFACE GetProjectionOfdNTdXt END MODULE ElemshapeData_ProjectionMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 index 1e6259bd7..deb176da3 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 @@ -109,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_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index a766403e7..15103845f 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -121,77 +121,77 @@ END PROCEDURE GetProjectionOfdNdXt3_ !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt +! GetProjectionOfdNTdXt !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNTdXt_1 -INTEGER(I4B) :: ii, nsd - -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)) -END DO +! INTEGER(I4B) :: ii, nsd +! +! 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)) +! END DO END PROCEDURE GetProjectionOfdNTdXt_1 !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt +! GetProjectionOfdNTdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNTdXt_2 -INTEGER(I4B) :: ii, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :) - -CALL getInterpolation(obj=obj, val=val, ans=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)) -END DO - -DEALLOCATE (cbar) -END PROCEDURE getProjectionOfdNTdXt_2 +MODULE PROCEDURE GetProjectionOfdNTdXt_2 +! INTEGER(I4B) :: ii, nsd +! REAL(DFP), ALLOCATABLE :: cbar(:, :) +! +! CALL getInterpolation(obj=obj, val=val, ans=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)) +! END DO +! +! DEALLOCATE (cbar) +END PROCEDURE GetProjectionOfdNTdXt_2 !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt +! GetProjectionOfdNTdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNTdXt_3 -INTEGER(I4B) :: ii, jj, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - -CALL getInterpolation(obj=obj, val=val, ans=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 DO -END DO - -DEALLOCATE (cbar) -END PROCEDURE getProjectionOfdNTdXt_3 +MODULE PROCEDURE GetProjectionOfdNTdXt_3 +! INTEGER(I4B) :: ii, jj, nsd +! REAL(DFP), ALLOCATABLE :: cbar(:, :, :) +! +! CALL getInterpolation(obj=obj, val=val, ans=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 DO +! END DO +! +! DEALLOCATE (cbar) +END PROCEDURE GetProjectionOfdNTdXt_3 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 index d228a77bb..8e4751700 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 @@ -175,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 !! @@ -183,7 +184,8 @@ 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 GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) CALL GetInterpolation(obj=obj, val=nu, ans=nubar) !! IF (PRESENT(k)) THEN @@ -442,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 !! @@ -450,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/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 3cf8f47db..a91c471ef 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_10.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_10.inc @@ -52,7 +52,8 @@ PURE SUBROUTINE STCM_10a(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) IaJb = IaJb + realval(ips) & @@ -107,7 +108,8 @@ PURE SUBROUTINE STCM_10b(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) IaJb = IaJb + realval(ips) & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc index 20e92d24e..6a92007b5 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc @@ -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) @@ -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) @@ -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) @@ -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 0c46e634e..d03ec6132 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_12.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_12.inc @@ -53,7 +53,8 @@ PURE SUBROUTINE STCM_12a(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) IaJb = IaJb + realval(ips) & @@ -106,7 +107,8 @@ PURE SUBROUTINE STCM_12b(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) IaJb = IaJb + realval(ips) & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_17.inc b/src/submodules/STConvectiveMatrix/src/STCM_17.inc index 4a38201a5..de96d90a6 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc @@ -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) @@ -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) @@ -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) @@ -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) 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 949ebea9b..5e13cc4ea 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_7.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_7.inc @@ -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) @@ -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) @@ -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) @@ -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 25456541a..09162f556 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_9.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_9.inc @@ -49,7 +49,8 @@ PURE SUBROUTINE STCM_9a(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) IaJb = IaJb + realval(ips) & @@ -101,7 +102,7 @@ PURE SUBROUTINE STCM_9b(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) !! diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 index ee949659d..221c93fa0 100644 --- a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 @@ -759,9 +759,11 @@ END SUBROUTINE MakeDiagonalCopiesIJab 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) !! @@ -903,8 +905,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! 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) + 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) !! @@ -1016,8 +1020,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! 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) + 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) !! diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 53b39a118..22ec03d67 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -415,7 +415,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c, & + crank=TypeFEVariableVector) CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) @@ -445,7 +446,8 @@ nrow = test(1)%nns ncol = test(1)%nnt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c, & + crank=TypeFEVariableVector) ! CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) @@ -472,7 +474,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & + crank=TypeFEVariableVector) CALL getInterpolation(obj=test, ans=c2bar, val=c2) CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) @@ -496,7 +499,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & + crank=TypeFEVariableVector) CALL GetInterpolation(obj=test, ans=c2bar, val=c2) CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test(1)%N, 1), SIZE(test(1)%T)) @@ -523,7 +527,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & + crank=TypeFEVariableVector) CALL GetInterpolation(obj=test, ans=c2bar, val=c2) CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test(1)%N, 1), & @@ -550,7 +555,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & + crank=TypeFEVariableVector) CALL GetInterpolation(obj=test, ans=c2bar, val=c2) CALL GetInterpolation(obj=test, ans=c3bar, val=c3) @@ -580,7 +586,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & + crank=TypeFEVariableVector) CALL GetInterpolation(obj=test, ans=c2bar, val=c2) CALL GetInterpolation(obj=test, ans=c3bar, val=c3) @@ -611,7 +618,8 @@ REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) INTEGER(I4B) :: ips, ipt -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) +CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & + crank=TypeFEVariableVector) CALL GetInterpolation(obj=test, ans=c2bar, val=c2) CALL GetInterpolation(obj=test, ans=c3bar, val=c3) From 7c876355eaaba3292a2c0c7c54a5717970dafc79 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 14:01:02 +0900 Subject: [PATCH 149/184] Updating MatmulUtility --- src/modules/Utility/src/MatmulUtility.F90 | 286 ++++++++++++++++-- .../Utility/src/MatmulUtility@Methods.F90 | 285 ++++++++++++++--- 2 files changed, 502 insertions(+), 69 deletions(-) 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/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 From a1d1db76f91a1f6592121a196bf2d3639b6b4232 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 19:52:37 +0900 Subject: [PATCH 150/184] Updating BaseType --- src/modules/BaseType/src/BaseType.F90 | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 83e402a2a..052339e3e 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -221,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_ @@ -1436,6 +1437,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_ !---------------------------------------------------------------------------- From e80b4f46bb67e2a89d949d0e0337aba09c57df99 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 19:53:07 +0900 Subject: [PATCH 151/184] Updating ElemshapeData Updating GetProjection method --- .../src/ElemshapeData_ProjectionMethods.F90 | 99 +++++++++- ...lemshapeData_ProjectionMethods@Methods.F90 | 174 ++++++++++++------ 2 files changed, 214 insertions(+), 59 deletions(-) diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 6dbebe606..4ea20281e 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -16,17 +16,16 @@ ! MODULE ElemshapeData_ProjectionMethods -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_, & + FEVariableVector_ +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE PRIVATE PUBLIC :: GetProjectionOfdNdXt PUBLIC :: GetProjectionOfdNdXt_ PUBLIC :: GetProjectionOfdNTdXt - -! TODO: implement -! PUBLIC :: getProjectionOfdNTdXt_ +PUBLIC :: GetProjectionOfdNTdXt_ !---------------------------------------------------------------------------- ! GetProjectionOfdNdXt @@ -212,6 +211,36 @@ END SUBROUTINE GetProjectionOfdNTdXt_1 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 + 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 GetProjectionOfdNTdXt1_ +END INTERFACE GetProjectionOfdNTdXt_ + !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt@getMethod !---------------------------------------------------------------------------- @@ -247,6 +276,27 @@ END SUBROUTINE GetProjectionOfdNTdXt_2 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 + 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 GetProjectionOfdNTdXt2_ +END INTERFACE GetProjectionOfdNTdXt_ + !---------------------------------------------------------------------------- ! GetProjectionOfdNTdXt@getMethod !---------------------------------------------------------------------------- @@ -281,4 +331,43 @@ END SUBROUTINE GetProjectionOfdNTdXt_3 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 GetProjectionOfdNTdXt4_( & + obj, c, crank, ans, nrow, ncol, ips, ipt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + 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 GetProjectionOfdNTdXt4_ +END INTERFACE GetProjectionOfdNTdXt_ + END MODULE ElemshapeData_ProjectionMethods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index 15103845f..08eb339cf 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -16,9 +16,10 @@ ! SUBMODULE(ElemshapeData_ProjectionMethods) Methods -USE BaseMethod +USE FEVariable_Method, ONLY: GetInterpolation_ +USE ReallocateUtility, ONLY: Reallocate +USE MatmulUtility, ONLY: Matmul_ -! USE FEVariable_Method, only: FEVariableGetInterpolation_ => GetInterpolation_ IMPLICIT NONE CONTAINS @@ -125,74 +126,139 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNTdXt_1 -! INTEGER(I4B) :: ii, nsd -! -! 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)) -! END DO +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 GetProjectionOfdNTdXt1_ + !---------------------------------------------------------------------------- ! GetProjectionOfdNTdXt !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNTdXt_2 -! INTEGER(I4B) :: ii, nsd -! REAL(DFP), ALLOCATABLE :: cbar(:, :) -! -! CALL getInterpolation(obj=obj, val=val, ans=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)) -! END DO -! -! DEALLOCATE (cbar) +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 +END PROCEDURE GetProjectionOfdNTdXt2_ + !---------------------------------------------------------------------------- ! GetProjectionOfdNTdXt !---------------------------------------------------------------------------- MODULE PROCEDURE GetProjectionOfdNTdXt_3 -! INTEGER(I4B) :: ii, jj, nsd -! REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -! -! CALL getInterpolation(obj=obj, val=val, ans=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 DO -! END DO -! -! DEALLOCATE (cbar) +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 +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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From b144b126147e352f0ef5fe568f8c5ed683df46ed Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 19:53:21 +0900 Subject: [PATCH 152/184] Updating ProductUtility --- src/modules/Utility/src/ProductUtility.F90 | 843 ++++++++++-------- .../Utility/src/ProductUtility@Methods.F90 | 16 + 2 files changed, 463 insertions(+), 396 deletions(-) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index 87a487453..ebd46e0dc 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -24,22 +24,20 @@ MODULE ProductUtility PUBLIC :: OuterProd PUBLIC :: OuterProd_ - PUBLIC :: OTimesTilda - PUBLIC :: Cross_Product PUBLIC :: Vector_Product PUBLIC :: VectorProduct !---------------------------------------------------------------------------- -! OTimesTilda@Methods +! OTimesTilda !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2024-08-13 ! summary: returns a space-time matrix from time and space matrix -INTERFACE OTimesTilda +INTERFACE MODULE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) @@ -48,17 +46,21 @@ MODULE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale) REAL(DFP), INTENT(IN) :: anscoeff REAL(DFP), INTENT(IN) :: scale END SUBROUTINE OTimesTilda1 +END INTERFACE + +INTERFACE OTimesTilda + MODULE PROCEDURE OTimesTilda1 END INTERFACE OTimesTilda !---------------------------------------------------------------------------- -! OtimesTilda@Methods +! OtimesTilda !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2024-08-13 ! summary: returns a space-time vector from time and space vector -INTERFACE OTimesTilda +INTERFACE MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) @@ -67,10 +69,14 @@ MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) REAL(DFP), INTENT(IN) :: anscoeff REAL(DFP), INTENT(IN) :: scale END SUBROUTINE OTimesTilda2 +END INTERFACE + +INTERFACE OTimesTilda + MODULE PROCEDURE OTimesTilda2 END INTERFACE OTimesTilda !---------------------------------------------------------------------------- -! Cross_Product@ProductMethods +! Cross_Product !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -81,20 +87,24 @@ END SUBROUTINE OTimesTilda2 ! This FUNCTION evaluate vectors products ! $$\mathbf{ans} = \mathbf{a} \times \mathbf{b}$$ -INTERFACE Vector_Product +INTERFACE MODULE PURE FUNCTION vectorProduct_1(a, b) RESULT(c) ! Define INTENT of dummy argument REAL(REAL64), INTENT(IN) :: a(3), b(3) REAL(REAL64) :: c(3) END FUNCTION vectorProduct_1 -END INTERFACE Vector_Product +END INTERFACE -INTERFACE Vector_Product +INTERFACE MODULE PURE FUNCTION vectorProduct_2(a, b) RESULT(c) ! Define INTENT of dummy argument REAL(REAL32), INTENT(IN) :: a(3), b(3) REAL(REAL32) :: c(3) END FUNCTION vectorProduct_2 +END INTERFACE + +INTERFACE Vector_Product + MODULE PROCEDURE vectorProduct_1, vectorProduct_2 END INTERFACE Vector_Product INTERFACE Cross_Product @@ -106,29 +116,33 @@ END FUNCTION 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 OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1(a, b) RESULT(ans) REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans END FUNCTION OuterProd_r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd_@ProductMethods +! OuterProd_ !---------------------------------------------------------------------------- -INTERFACE OuterProd_ +INTERFACE MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, & ncol) REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b @@ -142,10 +156,14 @@ MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, & 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_ !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -158,20 +176,24 @@ END SUBROUTINE OuterProd_r1r1_ ! - $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ ! - If `sym` is .true. THEN symmetric part is returned -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1s(a, b, sym) RESULT(ans) ! Define INTENT of dummy variables REAL(DFP), INTENT(IN) :: a(:), b(:) REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans LOGICAL(LGT), INTENT(IN) :: sym END FUNCTION OuterProd_r1r1s +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1s END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd_@ProductMethods +! OuterProd_ !---------------------------------------------------------------------------- -INTERFACE OuterProd_ +INTERFACE MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, & nrow, ncol) ! Define INTENT of dummy variables @@ -182,10 +204,14 @@ MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, & 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_ !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -193,23 +219,27 @@ END SUBROUTINE OuterProd_r1r1s_ ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2)) END FUNCTION OuterProd_r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd_@ProductMethods +! OuterProd_ !---------------------------------------------------------------------------- !> author: Shion Shimizu ! date: 2025-03-05 ! summary: a x b -INTERFACE OuterProd_ +INTERFACE MODULE PURE SUBROUTINE OuterProd_r1r2_(a, b, anscoeff, scale, ans, & dim1, dim2, dim3) REAL(DFP), INTENT(IN) :: a(:) @@ -218,10 +248,14 @@ MODULE PURE SUBROUTINE OuterProd_r1r2_(a, b, anscoeff, scale, ans, & 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@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -229,16 +263,20 @@ END SUBROUTINE OuterProd_r1r2_ ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3)) END FUNCTION OuterProd_r1r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -246,16 +284,20 @@ END FUNCTION OuterProd_r1r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r4(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), SIZE(b, 4)) END FUNCTION OuterProd_r1r4 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r4 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -263,45 +305,48 @@ END FUNCTION OuterProd_r1r4 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 ! summary: This FUNCTION returns OuterProduct -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b)) END FUNCTION OuterProd_r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd_@ProductMethods +! OuterProd_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2025-09-04 ! summary: a x b -INTERFACE OuterProd_ +INTERFACE MODULE PURE SUBROUTINE OuterProd_r2r1_(a, b, anscoeff, scale, ans, & dim1, dim2, dim3) REAL(DFP), INTENT(IN) :: a(:, :) @@ -310,10 +355,14 @@ MODULE PURE SUBROUTINE OuterProd_r2r1_(a, b, anscoeff, scale, ans, & 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@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -321,20 +370,20 @@ END SUBROUTINE OuterProd_r2r1_ ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +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)) + 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_r2r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -342,21 +391,45 @@ END FUNCTION OuterProd_r2r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE + 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), 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_ + +!---------------------------------------------------------------------------- +! OuterProd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -364,22 +437,21 @@ END FUNCTION OuterProd_r2r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -387,20 +459,20 @@ END FUNCTION OuterProd_r2r4 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -408,21 +480,21 @@ END FUNCTION OuterProd_r3r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -430,22 +502,21 @@ END FUNCTION OuterProd_r3r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -453,21 +524,21 @@ END FUNCTION OuterProd_r3r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -475,22 +546,21 @@ END FUNCTION OuterProd_r4r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -498,22 +568,21 @@ END FUNCTION OuterProd_r4r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE 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)) + 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@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -521,20 +590,21 @@ END FUNCTION OuterProd_r5r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +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)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1)) END FUNCTION OuterProd_r1r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -559,7 +629,7 @@ END SUBROUTINE OuterProd_r1r1r1_ END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -567,21 +637,21 @@ END SUBROUTINE OuterProd_r1r1r1_ ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +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)) + 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_r1r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -589,22 +659,22 @@ END FUNCTION OuterProd_r1r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -612,23 +682,22 @@ END FUNCTION OuterProd_r1r1r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -636,21 +705,21 @@ END FUNCTION OuterProd_r1r1r4 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -658,22 +727,22 @@ END FUNCTION OuterProd_r1r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -681,23 +750,22 @@ END FUNCTION OuterProd_r1r2r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -705,22 +773,22 @@ END FUNCTION OuterProd_r1r2r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -728,23 +796,22 @@ END FUNCTION OuterProd_r1r3r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -752,23 +819,22 @@ END FUNCTION OuterProd_r1r3r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -790,7 +856,7 @@ END FUNCTION OuterProd_r2r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd_@PROD +! OuterProd_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -815,7 +881,7 @@ END SUBROUTINE OuterProd_r2r1r1_ END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -823,22 +889,22 @@ END SUBROUTINE OuterProd_r2r1r1_ ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -846,23 +912,22 @@ END FUNCTION OuterProd_r2r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -870,22 +935,22 @@ END FUNCTION OuterProd_r2r1r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -893,23 +958,22 @@ END FUNCTION OuterProd_r2r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -917,22 +981,22 @@ END FUNCTION OuterProd_r2r2r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -940,23 +1004,22 @@ END FUNCTION OuterProd_r3r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -964,23 +1027,22 @@ END FUNCTION OuterProd_r3r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -988,23 +1050,22 @@ END FUNCTION OuterProd_r3r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1012,22 +1073,22 @@ END FUNCTION OuterProd_r4r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1035,23 +1096,23 @@ END FUNCTION OuterProd_r1r1r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1059,24 +1120,23 @@ END FUNCTION OuterProd_r1r1r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1084,23 +1144,23 @@ END FUNCTION OuterProd_r1r1r1r3 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1108,24 +1168,23 @@ END FUNCTION OuterProd_r1r1r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1133,24 +1192,23 @@ END FUNCTION OuterProd_r1r1r2r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1158,23 +1216,23 @@ END FUNCTION OuterProd_r1r1r3r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1182,24 +1240,23 @@ END FUNCTION OuterProd_r1r2r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1207,24 +1264,23 @@ END FUNCTION OuterProd_r1r2r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1232,24 +1288,23 @@ END FUNCTION OuterProd_r1r2r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1257,23 +1312,23 @@ END FUNCTION OuterProd_r1r3r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1281,24 +1336,23 @@ END FUNCTION OuterProd_r2r1r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1306,24 +1360,23 @@ END FUNCTION OuterProd_r2r1r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1331,24 +1384,23 @@ END FUNCTION OuterProd_r2r1r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1356,20 +1408,19 @@ END FUNCTION OuterProd_r2r2r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE 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)) + 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 14d0efb6f..d47b1ba06 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -254,6 +254,22 @@ ! !---------------------------------------------------------------------------- +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_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r2r3 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 3) From 6009b81f7056727f9e5f131c4b39417f8aa529e7 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 24 Nov 2025 19:53:33 +0900 Subject: [PATCH 153/184] Updating STForceVector method --- .../src/STForceVector_Method.F90 | 81 +- .../src/STForceVector_Method@Methods.F90 | 698 +++++++++++------- 2 files changed, 487 insertions(+), 292 deletions(-) diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index 38a33ac78..a20250578 100644 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -683,10 +683,10 @@ END SUBROUTINE obj_STForceVector_14 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION obj_STForceVector15(test, projecton, c, crank) & + MODULE PURE FUNCTION obj_STForceVector15(test, projection, c, crank) & RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableVector_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :) @@ -706,17 +706,18 @@ END FUNCTION obj_STForceVector15 ! summary: Space time force vector ! - - INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_15( & - test, projecton, c, crank, ans, nrow, ncol) + test, projection, c, crank, ans, nrow, ncol, temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + 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 @@ -734,9 +735,9 @@ END SUBROUTINE obj_STForceVector_15 INTERFACE MODULE PURE FUNCTION obj_STForceVector16( & - test, projecton, c1, c1rank, c2, c2rank) RESULT(ans) + test, projection, c1, c1rank, c2, c2rank) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariableVector_), INTENT(IN) :: c1rank @@ -759,15 +760,18 @@ END FUNCTION obj_STForceVector16 INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_16( & - test, projecton, c1, c1rank, c2, c2rank, ans, nrow, ncol) + test, projection, c1, c1rank, c2, c2rank, ans, nrow, ncol, temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + 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 @@ -785,11 +789,13 @@ END SUBROUTINE obj_STForceVector_16 INTERFACE MODULE PURE FUNCTION obj_STForceVector17( & - test, projecton, c1, c1rank, c2, c2rank) RESULT(ans) + test, projection, c1, c1rank, c2, c2rank) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + 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(:, :, :) @@ -810,15 +816,18 @@ END FUNCTION obj_STForceVector17 INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_17( & - test, projecton, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3) + test, projection, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + 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 @@ -836,9 +845,9 @@ END SUBROUTINE obj_STForceVector_17 INTERFACE MODULE PURE FUNCTION obj_STForceVector18( & - test, projecton, c1, c1rank, c2, c2rank) RESULT(ans) + test, projection, c1, c1rank, c2, c2rank) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariableVector_), INTENT(IN) :: c1rank @@ -861,15 +870,18 @@ END FUNCTION obj_STForceVector18 INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_18( & - test, projecton, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4) + test, projection, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4, & + temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + 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 @@ -887,9 +899,9 @@ END SUBROUTINE obj_STForceVector_18 INTERFACE MODULE PURE FUNCTION obj_STForceVector19( & - test, projecton, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) + test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariable_), INTENT(IN) :: c3 @@ -914,9 +926,10 @@ END FUNCTION obj_STForceVector19 INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_19( & - test, projecton, c1, c1rank, c2, c2rank, c3, c3rank, ans, nrow, ncol) + test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, nrow, ncol, & + temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariable_), INTENT(IN) :: c3 @@ -925,6 +938,7 @@ MODULE PURE SUBROUTINE obj_STForceVector_19( & 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 @@ -942,9 +956,9 @@ END SUBROUTINE obj_STForceVector_19 INTERFACE MODULE PURE FUNCTION obj_STForceVector20( & - test, projecton, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) + test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariable_), INTENT(IN) :: c3 @@ -969,18 +983,20 @@ END FUNCTION obj_STForceVector20 INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_20( & - test, projecton, c1, c1rank, c2, c2rank, c3, c3rank, ans, & - dim1, dim2, dim3) + test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, & + dim1, dim2, dim3, temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + 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 @@ -998,9 +1014,9 @@ END SUBROUTINE obj_STForceVector_20 INTERFACE MODULE PURE FUNCTION obj_STForceVector21( & - test, projecton, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) + test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariable_), INTENT(IN) :: c3 @@ -1025,10 +1041,10 @@ END FUNCTION obj_STForceVector21 INTERFACE MODULE PURE SUBROUTINE obj_STForceVector_21( & - test, projecton, c1, c1rank, c2, c2rank, c3, c3rank, ans, dim1, dim2, & - dim3, dim4) + test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, dim1, dim2, & + dim3, dim4, temp) CLASS(STElemshapeData_), INTENT(IN) :: test(:) - CHARACTER(LEN=*), INTENT(IN) :: projecton + CHARACTER(LEN=*), INTENT(IN) :: projection TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariable_), INTENT(IN) :: c3 @@ -1037,6 +1053,7 @@ MODULE PURE SUBROUTINE obj_STForceVector_21( & 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 diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 22ec03d67..8a50e8eb6 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -16,36 +16,42 @@ ! 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 ElemshapeData_Method, ONLY: GetProjectionOfdNdXt +USE ElemshapeData_Method, ONLY: GetProjectionOfdNTdXt_ IMPLICIT NONE CONTAINS -#include "./include/STFV_1.F90" -#include "./include/STFV_2.F90" -#include "./include/STFV_3.F90" -#include "./include/STFV_4.F90" -#include "./include/STFV_5.F90" -#include "./include/STFV_6.F90" -#include "./include/STFV_7.F90" - -#include "./include/STFV_8.F90" -#include "./include/STFV_9.F90" -#include "./include/STFV_10.F90" -#include "./include/STFV_11.F90" -#include "./include/STFV_12.F90" -#include "./include/STFV_13.F90" -#include "./include/STFV_14.F90" - -#include "./include/STFV_15.F90" -#include "./include/STFV_16.F90" -#include "./include/STFV_17.F90" -#include "./include/STFV_18.F90" -#include "./include/STFV_19.F90" -#include "./include/STFV_20.F90" -#include "./include/STFV_21.F90" +! #include "./include/STFV_1.F90" +! #include "./include/STFV_2.F90" +! #include "./include/STFV_3.F90" +! #include "./include/STFV_4.F90" +! #include "./include/STFV_5.F90" +! #include "./include/STFV_6.F90" +! #include "./include/STFV_7.F90" +! +! #include "./include/STFV_8.F90" +! #include "./include/STFV_9.F90" +! #include "./include/STFV_10.F90" +! #include "./include/STFV_11.F90" +! #include "./include/STFV_12.F90" +! #include "./include/STFV_13.F90" +! #include "./include/STFV_14.F90" +! +! #include "./include/STFV_15.F90" +! #include "./include/STFV_16.F90" +! #include "./include/STFV_17.F90" +! #include "./include/STFV_18.F90" +! #include "./include/STFV_19.F90" +! #include "./include/STFV_20.F90" +! #include "./include/STFV_21.F90" !---------------------------------------------------------------------------- ! STForceVector @@ -169,7 +175,7 @@ DO ips = 1, test(ipt)%nips - CALL GetInterpolation_( & + 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)%nns, scale=1.0_DFP, & addContribution=.TRUE., ans=cbar, tsize=spaceCompo) @@ -223,7 +229,7 @@ DO ips = 1, test(ipt)%nips - CALL GetInterpolation_( & + 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)%nns, scale=1.0_DFP, & addContribution=.TRUE., ans=cbar, nrow=i1, ncol=i2) @@ -411,26 +417,17 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector15 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c, & - crank=TypeFEVariableVector) - -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 +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: nrow, ncol -END DO +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 (realval, p1) +DEALLOCATE (temp) END PROCEDURE obj_STForceVector15 !---------------------------------------------------------------------------- @@ -438,30 +435,29 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector_15 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt, nipt +REAL(DFP) :: realval +INTEGER(I4B) :: ips, ipt, nipt, i1, i2 nipt = SIZE(test) nrow = test(1)%nns ncol = test(1)%nnt -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c, & - crank=TypeFEVariableVector) - -! CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) +ans(1:nrow, 1:ncol) = 0.0_DFP DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt - DO ips = 1, test(ipt)%nips - ans = ans + realval(ips) * p1(:, :, ips, ipt) + 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 - -DEALLOCATE (realval, p1) END PROCEDURE obj_STForceVector_15 !---------------------------------------------------------------------------- @@ -469,215 +465,390 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector16 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt +INTEGER(I4B) :: nrow, ncol +REAL(DFP), ALLOCATABLE :: temp(:, :) -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & - crank=TypeFEVariableVector) -CALL getInterpolation(obj=test, ans=c2bar, val=c2) +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 -CALL Reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) +!---------------------------------------------------------------------------- +! 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 -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) +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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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 obj_STForceVector16 +END PROCEDURE obj_STForceVector_16 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector17 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt +INTEGER(I4B) :: dim1, dim2, dim3 +REAL(DFP), ALLOCATABLE :: temp(:, :) -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & - crank=TypeFEVariableVector) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) +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 -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test(1)%N, 1), SIZE(test(1)%T)) +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- -DO ipt = 1, SIZE(test) +MODULE PROCEDURE obj_STForceVector_17 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3 +REAL(DFP) :: realval, c2bar(3) - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt + +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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips, ipt), & - p1(:, :, ips, ipt)) END DO END DO -DEALLOCATE (realval, p1, c2bar) -END PROCEDURE obj_STForceVector17 +END PROCEDURE obj_STForceVector_17 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector18 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & - crank=TypeFEVariableVector) -CALL GetInterpolation(obj=test, ans=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)) +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 + +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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + END DO END DO -DEALLOCATE (realval, p1, c2bar) -END PROCEDURE obj_STForceVector18 +END PROCEDURE obj_STForceVector_18 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector19 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt +INTEGER(I4B) :: nrow, ncol +REAL(DFP), ALLOCATABLE :: temp(:, :) -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & - crank=TypeFEVariableVector) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -CALL GetInterpolation(obj=test, ans=c3bar, val=c3) +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(temp, nrow, ncol) +CALL Reallocate(ans, nrow, ncol) -CALL reallocate(ans, SIZE(test(1)%N, 1), SIZE(test(1)%T)) +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) -DO ipt = 1, SIZE(test) - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - * c2bar(:, ipt) * c3bar(:, ipt) +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector19 - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- -END DO +MODULE PROCEDURE obj_STForceVector_19 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2 +REAL(DFP) :: realval, c2bar, c3bar -DEALLOCATE (realval, p1, c2bar, c3bar) -END PROCEDURE obj_STForceVector19 +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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 +END PROCEDURE obj_STForceVector_19 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector20 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & - crank=TypeFEVariableVector) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -CALL GetInterpolation(obj=test, ans=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 +INTEGER(I4B) :: dim1, dim2, dim3 +REAL(DFP), ALLOCATABLE :: temp(:, :) -END DO +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) -DEALLOCATE (realval, p1, c2bar, c3bar) +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 +! STForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_STForceVector21 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - -CALL GetProjectionOfdNTdXt(obj=test, ans=p1, c=c1, & - crank=TypeFEVariableVector) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -CALL GetInterpolation(obj=test, ans=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_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 + +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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + END DO END DO +END PROCEDURE obj_STForceVector_20 -DEALLOCATE (realval, p1, c2bar, c3bar) +!---------------------------------------------------------------------------- +! 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_STForceVector8 -SELECT CASE (term1) -CASE (DEL_NONE) - CALL STFV_1(ans=ans, test=test, term1=term1) +MODULE PROCEDURE obj_STForceVector_21 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3, i4 +REAL(DFP) :: realval, c3bar(3, 3), c2bar -CASE (DEL_t) - CALL STFV_8(ans=ans, test=test, term1=term1) +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c3, dim=1) +dim2 = FEVariableSize(obj=c3, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt -CASE (DEL_X, DEL_Y, DEL_Z) - CALL STFV_15(ans=ans, test=test, term1=term1) +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips -CASE (DEL_X_ALL) + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, & + ncol=i2) -END SELECT + 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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., ans=c2bar) -END PROCEDURE obj_STForceVector8 + 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)%nns, & + scale=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + + END DO +END DO +END PROCEDURE obj_STForceVector_21 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_STForceVector9 -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) +MODULE PROCEDURE obj_STForceVector8 +! SELECT CASE (term1) +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_1(ans=ans, test=test, term1=term1) +! +! CASE (TypeDerivativeTerm%t) +! CALL STFV_8(ans=ans, test=test, term1=term1) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_15(ans=ans, test=test, term1=term1) +! +! CASE (TypeDerivativeTerm%xAll) +! +! END SELECT +END PROCEDURE obj_STForceVector8 -CASE (DEL_X_ALL) -END SELECT +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- +MODULE PROCEDURE obj_STForceVector9 +! SELECT CASE (term1) +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_2(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%t) +! CALL STFV_9(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_16(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%xAll) +! END SELECT END PROCEDURE obj_STForceVector9 !---------------------------------------------------------------------------- @@ -685,19 +856,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector10 -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) - -END SELECT +! SELECT CASE (term1) +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_3(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%t) +! CALL STFV_10(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_17(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%xAll) +! +! END SELECT END PROCEDURE obj_STForceVector10 !---------------------------------------------------------------------------- @@ -705,19 +876,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector11 -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) - -END SELECT +! SELECT CASE (term1) +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_4(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%t) +! CALL STFV_11(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_18(ans=ans, test=test, term1=term1, c=c, crank=crank) +! +! CASE (TypeDerivativeTerm%xAll) +! +! END SELECT END PROCEDURE obj_STForceVector11 !---------------------------------------------------------------------------- @@ -725,21 +896,21 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector12 -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) - -END SELECT +! SELECT CASE (term1) +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_5(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! CASE (TypeDerivativeTerm%t) +! CALL STFV_12(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_19(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%xAll) +! +! END SELECT END PROCEDURE obj_STForceVector12 !---------------------------------------------------------------------------- @@ -747,19 +918,22 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector13 -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) -END SELECT +! SELECT CASE (term1) +! +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_6(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%t) +! CALL STFV_13(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_20(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%xAll) +! END SELECT END PROCEDURE obj_STForceVector13 !---------------------------------------------------------------------------- @@ -767,18 +941,22 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector14 -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) -END SELECT +! SELECT CASE (term1) +! +! CASE (TypeDerivativeTerm%NONE) +! CALL STFV_7(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%t) +! CALL STFV_14(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) +! CALL STFV_21(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & +! c2=c2, c2rank=c2rank) +! +! CASE (TypeDerivativeTerm%xAll) +! END SELECT END PROCEDURE obj_STForceVector14 !---------------------------------------------------------------------------- From bdc82f63b1a8df6b725ded4560d182cc5a76072a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 09:36:35 +0900 Subject: [PATCH 154/184] Updating STForceVectr --- .../src/STForceVector_Method.F90 | 2 +- .../src/STForceVector_Method@Methods.F90 | 873 ++++++++++++++++-- .../STForceVector/src/include/STFV_1.F90 | 55 -- .../STForceVector/src/include/STFV_10.F90 | 63 -- .../STForceVector/src/include/STFV_12.F90 | 63 -- .../STForceVector/src/include/STFV_16.F90 | 58 -- .../STForceVector/src/include/STFV_19.F90 | 63 -- .../STForceVector/src/include/STFV_2.F90 | 60 -- .../STForceVector/src/include/STFV_3.F90 | 64 -- .../STForceVector/src/include/STFV_4.F90 | 44 +- .../STForceVector/src/include/STFV_5.F90 | 66 -- .../STForceVector/src/include/STFV_8.F90 | 53 -- .../STForceVector/src/include/STFV_9.F90 | 58 -- 13 files changed, 780 insertions(+), 742 deletions(-) delete mode 100644 src/submodules/STForceVector/src/include/STFV_1.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_10.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_12.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_16.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_19.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_2.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_3.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_5.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_8.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_9.F90 diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index a20250578..eb174a318 100644 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -1053,7 +1053,7 @@ MODULE PURE SUBROUTINE obj_STForceVector_21( & TYPE(FEVariableMatrix_), INTENT(IN) :: c3rank REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 - REAL( DFP ), INTENT(INOUT) :: temp(:, :) + REAL(DFP), INTENT(INOUT) :: temp(:, :) END SUBROUTINE obj_STForceVector_21 END INTERFACE diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 8a50e8eb6..863c64a53 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -29,30 +29,6 @@ IMPLICIT NONE CONTAINS -! #include "./include/STFV_1.F90" -! #include "./include/STFV_2.F90" -! #include "./include/STFV_3.F90" -! #include "./include/STFV_4.F90" -! #include "./include/STFV_5.F90" -! #include "./include/STFV_6.F90" -! #include "./include/STFV_7.F90" -! -! #include "./include/STFV_8.F90" -! #include "./include/STFV_9.F90" -! #include "./include/STFV_10.F90" -! #include "./include/STFV_11.F90" -! #include "./include/STFV_12.F90" -! #include "./include/STFV_13.F90" -! #include "./include/STFV_14.F90" -! -! #include "./include/STFV_15.F90" -! #include "./include/STFV_16.F90" -! #include "./include/STFV_17.F90" -! #include "./include/STFV_18.F90" -! #include "./include/STFV_19.F90" -! #include "./include/STFV_20.F90" -! #include "./include/STFV_21.F90" - !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -83,8 +59,8 @@ DO ipt = 1, nipt DO ips = 1, test(ipt)%nips - realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * test(ipt)%jt * & - test(ipt)%thickness(ips) * test(ipt)%wt + 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=1.0_DFP, & @@ -113,7 +89,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector_2 -REAL(DFP) :: realval +REAL(DFP) :: realval, cbar INTEGER(I4B) :: nipt, ipt, ips, i1, i2 nipt = SIZE(test) @@ -128,9 +104,9 @@ 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=realval) + scale=1.0_DFP, addContribution=.TRUE., ans=cbar) - realval = realval * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt CALL OuterProd_( & @@ -278,13 +254,13 @@ 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=c1bar) + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=c2bar) + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., ans=c2bar) realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt @@ -332,12 +308,12 @@ 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=c1bar) + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.TRUE., ans=c2bar, tsize=i1) realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & @@ -489,6 +465,8 @@ nrow = test(1)%nns ncol = test(1)%nnt +ans(1:nrow, 1:ncol) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -541,6 +519,8 @@ dim2 = test(1)%nns dim3 = test(1)%nnt +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -601,6 +581,8 @@ dim3 = test(1)%nns dim4 = test(1)%nnt +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -658,6 +640,8 @@ nrow = test(1)%nns ncol = test(1)%nnt +ans(1:nrow, 1:ncol) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips CALL FEVariableGetInterpolation_( & @@ -718,6 +702,8 @@ dim2 = test(1)%nns dim3 = test(1)%nnt +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -783,6 +769,8 @@ dim3 = test(1)%nns dim4 = test(1)%nnt +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP + DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -817,101 +805,796 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector8 -! SELECT CASE (term1) -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_1(ans=ans, test=test, term1=term1) -! -! CASE (TypeDerivativeTerm%t) -! CALL STFV_8(ans=ans, test=test, term1=term1) -! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_15(ans=ans, test=test, term1=term1) -! +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 + +!---------------------------------------------------------------------------- ! -! END SELECT -END PROCEDURE obj_STForceVector8 +!---------------------------------------------------------------------------- + +! 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) = 0.0_DFP + + 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=1.0_DFP, 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) = 0.0_DFP + + 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) = 0.0_DFP + + 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 -! SELECT CASE (term1) -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_2(ans=ans, test=test, term1=term1, c=c, crank=crank) -! -! CASE (TypeDerivativeTerm%t) -! CALL STFV_9(ans=ans, test=test, term1=term1, c=c, crank=crank) -! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_16(ans=ans, test=test, term1=term1, c=c, crank=crank) -! -! CASE (TypeDerivativeTerm%xAll) -! END SELECT +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_STForceVector10 -! SELECT CASE (term1) -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_3(ans=ans, test=test, term1=term1, c=c, crank=crank) +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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval, ans=ans, nrow=i1, ncol=i2) + END DO + END DO +END SUBROUTINE STFV_9a + +!---------------------------------------------------------------------------- ! -! CASE (TypeDerivativeTerm%t) -! CALL STFV_10(ans=ans, test=test, term1=term1, c=c, crank=crank) +!---------------------------------------------------------------------------- + +! 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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 + +!---------------------------------------------------------------------------- ! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_17(ans=ans, test=test, term1=term1, c=c, crank=crank) +!---------------------------------------------------------------------------- + +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_STForceVector10 + +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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_10c !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector11 -! SELECT CASE (term1) -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_4(ans=ans, test=test, term1=term1, c=c, crank=crank) +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 + +!---------------------------------------------------------------------------- ! -! CASE (TypeDerivativeTerm%t) -! CALL STFV_11(ans=ans, test=test, term1=term1, c=c, crank=crank) +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- ! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_18(ans=ans, test=test, term1=term1, c=c, crank=crank) +!---------------------------------------------------------------------------- + +! 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_11a + +!---------------------------------------------------------------------------- ! -! CASE (TypeDerivativeTerm%xAll) +!---------------------------------------------------------------------------- + +! 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_11b + +!---------------------------------------------------------------------------- ! -! END SELECT -END PROCEDURE obj_STForceVector11 +!---------------------------------------------------------------------------- + +! 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_11c !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector12 -! SELECT CASE (term1) -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_5(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! CASE (TypeDerivativeTerm%t) -! CALL STFV_12(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_19(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) +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_STForceVector12 + +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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, addContribution=.FALSE., 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) = 0.0_DFP + + 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=1.0_DFP, addContribution=.FALSE., 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=1.0_DFP, addContribution=.FALSE., 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 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/STForceVector/src/include/STFV_1.F90 b/src/submodules/STForceVector/src/include/STFV_1.F90 deleted file mode 100644 index 545c440c8..000000000 --- a/src/submodules/STForceVector/src/include/STFV_1.F90 +++ /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/include/STFV_10.F90 b/src/submodules/STForceVector/src/include/STFV_10.F90 deleted file mode 100644 index c6cc71efc..000000000 --- a/src/submodules/STForceVector/src/include/STFV_10.F90 +++ /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, ans=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/include/STFV_12.F90 b/src/submodules/STForceVector/src/include/STFV_12.F90 deleted file mode 100644 index 61a30dd9b..000000000 --- a/src/submodules/STForceVector/src/include/STFV_12.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_16.F90 b/src/submodules/STForceVector/src/include/STFV_16.F90 deleted file mode 100644 index b9884f947..000000000 --- a/src/submodules/STForceVector/src/include/STFV_16.F90 +++ /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, ans=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/include/STFV_19.F90 b/src/submodules/STForceVector/src/include/STFV_19.F90 deleted file mode 100644 index bf776e476..000000000 --- a/src/submodules/STForceVector/src/include/STFV_19.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_2.F90 b/src/submodules/STForceVector/src/include/STFV_2.F90 deleted file mode 100644 index 5a162d800..000000000 --- a/src/submodules/STForceVector/src/include/STFV_2.F90 +++ /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, ans=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/include/STFV_3.F90 b/src/submodules/STForceVector/src/include/STFV_3.F90 deleted file mode 100644 index de9717b3e..000000000 --- a/src/submodules/STForceVector/src/include/STFV_3.F90 +++ /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, ans=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/include/STFV_4.F90 b/src/submodules/STForceVector/src/include/STFV_4.F90 index d87c2e60a..be5e66c05 100644 --- a/src/submodules/STForceVector/src/include/STFV_4.F90 +++ b/src/submodules/STForceVector/src/include/STFV_4.F90 @@ -19,46 +19,4 @@ ! 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, ans=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/include/STFV_5.F90 b/src/submodules/STForceVector/src/include/STFV_5.F90 deleted file mode 100644 index 886663ef3..000000000 --- a/src/submodules/STForceVector/src/include/STFV_5.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_8.F90 b/src/submodules/STForceVector/src/include/STFV_8.F90 deleted file mode 100644 index dfe340b3f..000000000 --- a/src/submodules/STForceVector/src/include/STFV_8.F90 +++ /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/include/STFV_9.F90 b/src/submodules/STForceVector/src/include/STFV_9.F90 deleted file mode 100644 index 80b1620c8..000000000 --- a/src/submodules/STForceVector/src/include/STFV_9.F90 +++ /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, ans=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 From 252eaec42f87a9bbe6cc5da59f048c5ca6009867 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 09:42:36 +0900 Subject: [PATCH 155/184] Updating STForceVector_Method --- .../src/STForceVector_Method@Methods.F90 | 41 +++++++++---------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 863c64a53..7cf7e207c 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -23,7 +23,6 @@ USE BaseType, ONLY: TypeDerivativeTerm USE BaseType, ONLY: TypeFEVariableSpace, TypeFEVariableVector USE BaseType, ONLY: TypeFEVariableMatrix -USE ElemshapeData_Method, ONLY: GetProjectionOfdNdXt USE ElemshapeData_Method, ONLY: GetProjectionOfdNTdXt_ IMPLICIT NONE @@ -103,8 +102,8 @@ 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=cbar) + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., ans=cbar) realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt @@ -153,8 +152,8 @@ 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)%nns, scale=1.0_DFP, & - addContribution=.TRUE., ans=cbar, tsize=spaceCompo) + timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, scale=1.0_DFP, & + addContribution=.FALSE., ans=cbar, tsize=spaceCompo) realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt @@ -207,8 +206,8 @@ 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)%nns, scale=1.0_DFP, & - addContribution=.TRUE., ans=cbar, nrow=i1, ncol=i2) + timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, scale=1.0_DFP, & + addContribution=.FALSE., 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 @@ -314,7 +313,7 @@ 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=1.0_DFP, addContribution=.TRUE., ans=c2bar, tsize=i1) + scale=1.0_DFP, addContribution=.FALSE., ans=c2bar, tsize=i1) realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt @@ -368,13 +367,13 @@ 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=c1bar) + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & - scale=1.0_DFP, addContribution=.TRUE., ans=c2bar, nrow=i1, ncol=i2) + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., 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 @@ -472,7 +471,7 @@ 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., ans=realval) realval = realval * test(ipt)%js(ips) * test(ipt)%ws(ips) * & @@ -529,7 +528,7 @@ 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., ans=c2bar, tsize=i1) CALL GetProjectionOfdNTdXt_( & @@ -591,7 +590,7 @@ 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., ans=c2bar, nrow=i1, ncol=i2) CALL GetProjectionOfdNTdXt_( & @@ -646,12 +645,12 @@ 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., ans=c3bar) realval = c2bar * c3bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & @@ -709,12 +708,12 @@ 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., ans=c3bar, tsize=i1) CALL GetProjectionOfdNTdXt_( & @@ -780,12 +779,12 @@ 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., 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)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & scale=1.0_DFP, addContribution=.FALSE., ans=c3bar, nrow=i1, ncol=i2) realval = c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & From 366675bb50f8a6c5b236f5b8eea7d18e43a87811 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 09:45:57 +0900 Subject: [PATCH 156/184] Updating BaseType Adding MathOpt_ --- src/modules/BaseType/src/BaseType.F90 | 36 ++++++++++++++++----------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 052339e3e..8ff408e5c 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -91,7 +91,7 @@ MODULE BaseType IMPLICIT NONE PRIVATE -PUBLIC :: Math +PUBLIC :: TypeMathOpt PUBLIC :: BoundingBox_ PUBLIC :: TypeBoundingBox PUBLIC :: BoundingBoxPointer_ @@ -264,29 +264,35 @@ MODULE BaseType 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) :: one = 1.0_DFP + REAL(DFP) :: zero = 0.0_DFP + REAL(DFP) :: half = 0.5_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_ - -TYPE(Math_), PARAMETER :: Math = Math_() + LOGICAL(LGT) :: yes = .TRUE. + LOGICAL(LGT) :: no = .FALSE. +END TYPE MathOpt_ + +TYPE(MathOpt_), PARAMETER :: TypeMathOpt = MathOpt_() !---------------------------------------------------------------------------- ! BoundingBox_ From 47684864d8bdfc742a9fe7d1af51efbb0d76094a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 10:57:23 +0900 Subject: [PATCH 157/184] Updating STForceVector All methods have been implemented. --- fortitude.toml | 10 + .../src/STForceVector_Method@Methods.F90 | 566 ++++++++++++++---- .../STForceVector/src/include/STFV_11.F90 | 63 -- .../STForceVector/src/include/STFV_13.F90 | 68 --- .../STForceVector/src/include/STFV_14.F90 | 68 --- .../STForceVector/src/include/STFV_15.F90 | 53 -- .../STForceVector/src/include/STFV_17.F90 | 63 -- .../STForceVector/src/include/STFV_18.F90 | 63 -- .../STForceVector/src/include/STFV_20.F90 | 68 --- .../STForceVector/src/include/STFV_21.F90 | 68 --- .../STForceVector/src/include/STFV_4.F90 | 22 - .../STForceVector/src/include/STFV_6.F90 | 69 --- .../STForceVector/src/include/STFV_7.F90 | 69 --- 13 files changed, 461 insertions(+), 789 deletions(-) create mode 100644 fortitude.toml delete mode 100644 src/submodules/STForceVector/src/include/STFV_11.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_13.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_14.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_15.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_17.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_18.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_20.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_21.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_4.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_6.F90 delete mode 100644 src/submodules/STForceVector/src/include/STFV_7.F90 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/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 7cf7e207c..bb3803f0a 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -23,6 +23,7 @@ USE BaseType, ONLY: TypeDerivativeTerm USE BaseType, ONLY: TypeFEVariableSpace, TypeFEVariableVector USE BaseType, ONLY: TypeFEVariableMatrix +USE BaseType, ONLY: math => TypeMathOpt USE ElemshapeData_Method, ONLY: GetProjectionOfdNTdXt_ IMPLICIT NONE @@ -54,7 +55,7 @@ nrow = test(1)%nns ncol = test(1)%nnt -ans(1:nrow, 1:ncol) = 0.0_DFP +ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -62,7 +63,7 @@ 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=1.0_DFP, & + 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 @@ -95,7 +96,7 @@ nrow = test(1)%nns ncol = test(1)%nnt -ans(1:nrow, 1:ncol) = 0.0_DFP +ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -103,13 +104,13 @@ 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=1.0_DFP, addContribution=.FALSE., ans=cbar) + 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=1.0_DFP, & + 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 @@ -144,7 +145,7 @@ dim2 = test(1)%nns dim3 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt @@ -152,14 +153,14 @@ 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=1.0_DFP, & - addContribution=.FALSE., ans=cbar, tsize=spaceCompo) + 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=1.0_DFP, scale=realval, & + c=test(ipt)%T(1:dim3), anscoeff=math%one, scale=realval, & ans=ans, dim1=i1, dim2=i2, dim3=i3) END DO @@ -198,7 +199,7 @@ dim3 = test(1)%nns dim4 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt @@ -206,14 +207,14 @@ 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=1.0_DFP, & - addContribution=.FALSE., ans=cbar, nrow=i1, ncol=i2) + 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=1.0_DFP, scale=realval, & + c=test(ipt)%T(1:dim4), anscoeff=math%one, scale=realval, & ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4) END DO @@ -246,7 +247,7 @@ nrow = test(1)%nns ncol = test(1)%nnt -ans(1:nrow, 1:ncol) = 0.0_DFP +ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -254,18 +255,18 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c1bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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=1.0_DFP, & + 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 @@ -300,7 +301,7 @@ dim2 = test(1)%nns dim3 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -308,19 +309,19 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c1bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c2bar, tsize=i1) + 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=1.0_DFP, & + c=test(ipt)%T(1:dim3), anscoeff=math%one, & scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3) END DO @@ -359,7 +360,7 @@ dim3 = test(1)%nns dim4 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt @@ -368,19 +369,19 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c1bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c2bar, nrow=i1, ncol=i2) + 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=1.0_DFP, & + c=test(ipt)%T(1:dim4), anscoeff=math%one, & scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4) END DO @@ -417,7 +418,7 @@ nrow = test(1)%nns ncol = test(1)%nnt -ans(1:nrow, 1:ncol) = 0.0_DFP +ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -464,7 +465,7 @@ nrow = test(1)%nns ncol = test(1)%nnt -ans(1:nrow, 1:ncol) = 0.0_DFP +ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -472,7 +473,7 @@ 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=1.0_DFP, addContribution=.FALSE., ans=realval) + 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 @@ -518,7 +519,7 @@ dim2 = test(1)%nns dim3 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -529,7 +530,7 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c2bar, tsize=i1) + 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, & @@ -537,7 +538,7 @@ CALL OuterProd_( & a=c2bar(1:dim1), b=temp(1:dim2, 1:dim3), & - ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=1.0_DFP, scale=realval) + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) END DO END DO @@ -580,7 +581,7 @@ dim3 = test(1)%nns dim4 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -591,7 +592,7 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c2bar, nrow=i1, ncol=i2) + 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, & @@ -600,7 +601,7 @@ 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=1.0_DFP, scale=realval) + anscoeff=math%one, scale=realval) END DO END DO @@ -639,19 +640,19 @@ nrow = test(1)%nns ncol = test(1)%nnt -ans(1:nrow, 1:ncol) = 0.0_DFP +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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c3bar) + 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 @@ -701,7 +702,7 @@ dim2 = test(1)%nns dim3 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -709,12 +710,12 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c3bar, tsize=i1) + 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, & @@ -725,7 +726,7 @@ CALL OuterProd_( & a=c3bar(1:dim1), b=temp(1:dim2, 1:dim3), & - ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=1.0_DFP, scale=realval) + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) END DO END DO @@ -768,7 +769,7 @@ dim3 = test(1)%nns dim4 = test(1)%nnt -ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -780,12 +781,12 @@ 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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c3bar, nrow=i1, ncol=i2) + 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 @@ -793,7 +794,7 @@ 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=1.0_DFP, scale=realval) + anscoeff=math%one, scale=realval) END DO END DO @@ -849,7 +850,7 @@ PURE SUBROUTINE STFV_8a(test, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -859,7 +860,7 @@ PURE SUBROUTINE STFV_8a(test, ans, nrow, ncol) CALL OuterProd_(a=test(ipt)%N(1:nrow, ips), & b=test(ipt)%T(1:ncol), & - anscoeff=1.0_DFP, scale=realval, & + anscoeff=math%one, scale=realval, & ans=ans, nrow=i1, ncol=i2) END DO END DO @@ -884,7 +885,7 @@ PURE SUBROUTINE STFV_8b(test, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -916,7 +917,7 @@ PURE SUBROUTINE STFV_8c(test, ans, term1, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -979,7 +980,7 @@ PURE SUBROUTINE STFV_9a(test, c, crank, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -987,14 +988,14 @@ PURE SUBROUTINE STFV_9a(test, c, crank, ans, nrow, ncol) 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=1.0_DFP, addContribution=.FALSE., ans=cbar) + 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=1.0_DFP, scale=realval, ans=ans, nrow=i1, ncol=i2) + anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2) END DO END DO END SUBROUTINE STFV_9a @@ -1019,7 +1020,7 @@ PURE SUBROUTINE STFV_9b(test, c, crank, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1027,7 +1028,7 @@ PURE SUBROUTINE STFV_9b(test, c, crank, ans, nrow, ncol) 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=1.0_DFP, addContribution=.FALSE., ans=cbar) + 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 @@ -1060,14 +1061,14 @@ PURE SUBROUTINE STFV_9c(test, term1, c, crank, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + 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=1.0_DFP, addContribution=.FALSE., ans=cbar) + 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 @@ -1135,7 +1136,7 @@ PURE SUBROUTINE STFV_10a(test, c, crank, ans, dim1, dim2, dim3) dim2 = test(1)%nns dim3 = test(1)%nnt - ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1143,7 +1144,7 @@ PURE SUBROUTINE STFV_10a(test, c, crank, ans, dim1, dim2, dim3) 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=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1) + 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 @@ -1152,7 +1153,7 @@ PURE SUBROUTINE STFV_10a(test, c, crank, ans, dim1, dim2, dim3) 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=1.0_DFP, scale=realval) + anscoeff=math%one, scale=realval) END DO END DO END SUBROUTINE STFV_10a @@ -1178,7 +1179,7 @@ PURE SUBROUTINE STFV_10b(test, c, crank, ans, dim1, dim2, dim3) dim2 = test(1)%nns dim3 = test(1)%nnt - ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1186,14 +1187,14 @@ PURE SUBROUTINE STFV_10b(test, c, crank, ans, dim1, dim2, dim3) 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=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1) + 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=1.0_DFP, scale=realval) + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) END DO END DO @@ -1221,7 +1222,7 @@ PURE SUBROUTINE STFV_10c(test, term1, c, crank, ans, dim1, dim2, dim3) dim2 = test(1)%nns dim3 = test(1)%nnt - ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1229,14 +1230,14 @@ PURE SUBROUTINE STFV_10c(test, term1, c, crank, ans, dim1, dim2, dim3) 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=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1) + 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=1.0_DFP, scale=realval) + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) END DO END DO @@ -1302,7 +1303,7 @@ PURE SUBROUTINE STFV_11a(test, c, crank, ans, dim1, dim2, dim3, dim4) dim4 = test(1)%nnt nipt = SIZE(test) - ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1310,7 +1311,7 @@ PURE SUBROUTINE STFV_11a(test, c, crank, ans, dim1, dim2, dim3, dim4) 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=1.0_DFP, addContribution=.FALSE., ans=cbar, nrow=i1, ncol=i2) + 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 @@ -1318,7 +1319,7 @@ PURE SUBROUTINE STFV_11a(test, c, crank, ans, dim1, dim2, dim3, dim4) 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=1.0_DFP, scale=realval) + anscoeff=math%one, scale=realval) END DO END DO @@ -1346,7 +1347,7 @@ PURE SUBROUTINE STFV_11b(test, c, crank, ans, dim1, dim2, dim3, dim4) dim4 = test(1)%nnt nipt = SIZE(test) - ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1354,7 +1355,7 @@ PURE SUBROUTINE STFV_11b(test, c, crank, ans, dim1, dim2, dim3, dim4) 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=1.0_DFP, addContribution=.FALSE., ans=cbar, nrow=i1, ncol=i2) + 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 @@ -1362,7 +1363,7 @@ PURE SUBROUTINE STFV_11b(test, c, crank, ans, dim1, dim2, dim3, dim4) 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=1.0_DFP, scale=realval) + anscoeff=math%one, scale=realval) END DO END DO @@ -1391,7 +1392,7 @@ PURE SUBROUTINE STFV_11c(test, term1, c, crank, ans, dim1, dim2, dim3, dim4) dim4 = test(1)%nnt nipt = SIZE(test) - ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = 0.0_DFP + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1399,7 +1400,7 @@ PURE SUBROUTINE STFV_11c(test, term1, c, crank, ans, dim1, dim2, dim3, dim4) 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=1.0_DFP, addContribution=.FALSE., ans=cbar, nrow=i1, ncol=i2) + 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 @@ -1408,7 +1409,7 @@ PURE SUBROUTINE STFV_11c(test, term1, c, crank, ans, dim1, dim2, dim3, dim4) 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=1.0_DFP, scale=realval) + anscoeff=math%one, scale=realval) END DO END DO @@ -1472,7 +1473,7 @@ PURE SUBROUTINE STFV_12a(test, c1, c1rank, c2, c2rank, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1480,19 +1481,19 @@ PURE SUBROUTINE STFV_12a(test, c1, c1rank, c2, c2rank, ans, nrow, ncol) 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=1.0_DFP, addContribution=.FALSE., ans=c1bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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=1.0_DFP, scale=realval, ans=ans, nrow=i1, ncol=i2) + anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2) END DO END DO @@ -1521,7 +1522,7 @@ PURE SUBROUTINE STFV_12b(test, c1, c1rank, c2, c2rank, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1529,12 +1530,12 @@ PURE SUBROUTINE STFV_12b(test, c1, c1rank, c2, c2rank, ans, nrow, ncol) 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=1.0_DFP, addContribution=.FALSE., ans=c1bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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 @@ -1570,7 +1571,7 @@ PURE SUBROUTINE STFV_12c(test, term1, c1, c1rank, c2, c2rank, ans, nrow, ncol) nrow = test(1)%nns ncol = test(1)%nnt - ans(1:nrow, 1:ncol) = 0.0_DFP + ans(1:nrow, 1:ncol) = math%zero DO ipt = 1, nipt DO ips = 1, test(ipt)%nips @@ -1578,12 +1579,12 @@ PURE SUBROUTINE STFV_12c(test, term1, c1, c1rank, c2, c2rank, ans, nrow, ncol) 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=1.0_DFP, addContribution=.FALSE., ans=c1bar) + 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=1.0_DFP, addContribution=.FALSE., ans=c2bar) + 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 @@ -1600,47 +1601,382 @@ END SUBROUTINE STFV_12c !---------------------------------------------------------------------------- MODULE PROCEDURE obj_STForceVector13 -! SELECT CASE (term1) -! -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_6(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! -! CASE (TypeDerivativeTerm%t) -! CALL STFV_13(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_20(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) +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_STForceVector13 +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 -! SELECT CASE (term1) -! -! CASE (TypeDerivativeTerm%NONE) -! CALL STFV_7(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! -! CASE (TypeDerivativeTerm%t) -! CALL STFV_14(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! -! CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) -! CALL STFV_21(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & -! c2=c2, c2rank=c2rank) -! -! CASE (TypeDerivativeTerm%xAll) -! END SELECT +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 !---------------------------------------------------------------------------- diff --git a/src/submodules/STForceVector/src/include/STFV_11.F90 b/src/submodules/STForceVector/src/include/STFV_11.F90 deleted file mode 100644 index 0709e4e88..000000000 --- a/src/submodules/STForceVector/src/include/STFV_11.F90 +++ /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, ans=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/include/STFV_13.F90 b/src/submodules/STForceVector/src/include/STFV_13.F90 deleted file mode 100644 index dd18c1d90..000000000 --- a/src/submodules/STForceVector/src/include/STFV_13.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_14.F90 b/src/submodules/STForceVector/src/include/STFV_14.F90 deleted file mode 100644 index 7264036ac..000000000 --- a/src/submodules/STForceVector/src/include/STFV_14.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_15.F90 b/src/submodules/STForceVector/src/include/STFV_15.F90 deleted file mode 100644 index a38e8e233..000000000 --- a/src/submodules/STForceVector/src/include/STFV_15.F90 +++ /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/include/STFV_17.F90 b/src/submodules/STForceVector/src/include/STFV_17.F90 deleted file mode 100644 index d3ec302bb..000000000 --- a/src/submodules/STForceVector/src/include/STFV_17.F90 +++ /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, ans=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/include/STFV_18.F90 b/src/submodules/STForceVector/src/include/STFV_18.F90 deleted file mode 100644 index 407a1c8a5..000000000 --- a/src/submodules/STForceVector/src/include/STFV_18.F90 +++ /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, ans=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/include/STFV_20.F90 b/src/submodules/STForceVector/src/include/STFV_20.F90 deleted file mode 100644 index 8aad09601..000000000 --- a/src/submodules/STForceVector/src/include/STFV_20.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_21.F90 b/src/submodules/STForceVector/src/include/STFV_21.F90 deleted file mode 100644 index 053f0f79f..000000000 --- a/src/submodules/STForceVector/src/include/STFV_21.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_4.F90 b/src/submodules/STForceVector/src/include/STFV_4.F90 deleted file mode 100644 index be5e66c05..000000000 --- a/src/submodules/STForceVector/src/include/STFV_4.F90 +++ /dev/null @@ -1,22 +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 -!---------------------------------------------------------------------------- - - diff --git a/src/submodules/STForceVector/src/include/STFV_6.F90 b/src/submodules/STForceVector/src/include/STFV_6.F90 deleted file mode 100644 index 91a8fd281..000000000 --- a/src/submodules/STForceVector/src/include/STFV_6.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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/include/STFV_7.F90 b/src/submodules/STForceVector/src/include/STFV_7.F90 deleted file mode 100644 index 608563190..000000000 --- a/src/submodules/STForceVector/src/include/STFV_7.F90 +++ /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, ans=c1bar, val=c1) - CALL getInterpolation(obj=test, ans=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 From 08a8bc6b685d9685c773ed0043e9a36566fcd1cb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 12:08:06 +0900 Subject: [PATCH 158/184] Updating BaseType --- src/modules/BaseType/src/BaseType.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 8ff408e5c..80e6224c1 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -290,6 +290,8 @@ MODULE BaseType COMPLEX(DFPC) :: j = (0.0_DFP, 1.0_DFP) LOGICAL(LGT) :: yes = .TRUE. LOGICAL(LGT) :: no = .FALSE. + INTEGER(I4B) :: one_i = 1_I4B + INTEGER(I4B) :: zero_i = 0_I4B END TYPE MathOpt_ TYPE(MathOpt_), PARAMETER :: TypeMathOpt = MathOpt_() From 5c02b9008d8c242e5ef674709e9cdebcf719cbc3 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 12:08:14 +0900 Subject: [PATCH 159/184] Updating ForceVector_Method --- .../ForceVector/src/ForceVector_Method.F90 | 103 ++++++-- .../src/ForceVector_Method@Methods.F90 | 250 +++++++----------- 2 files changed, 174 insertions(+), 179 deletions(-) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 929872ce5..3a8368b23 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -41,11 +41,15 @@ MODULE ForceVector_Method ! F_{I}=\int_{\Omega}N^{I}d\Omega ! $$ -INTERFACE ForceVector +INTERFACE MODULE FUNCTION ForceVector1(test) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), ALLOCATABLE :: ans(:) END FUNCTION ForceVector1 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector1 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -64,12 +68,16 @@ END FUNCTION ForceVector1 ! F_{I}=\int_{\Omega}N^{I}d\Omega ! $$ -INTERFACE ForceVector_ +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_ !---------------------------------------------------------------------------- @@ -86,13 +94,17 @@ END SUBROUTINE ForceVector_1 ! F_{I}=\int_{\Omega}\rho N^{I}d\Omega ! $$ -INTERFACE ForceVector +INTERFACE MODULE FUNCTION ForceVector2(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableScalar_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:) END FUNCTION ForceVector2 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector2 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -109,7 +121,7 @@ END FUNCTION ForceVector2 ! F_{I}=\int_{\Omega} c N^{I} d\Omega ! $$ -INTERFACE ForceVector_ +INTERFACE MODULE SUBROUTINE ForceVector_2(test, c, crank, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c @@ -118,6 +130,10 @@ MODULE SUBROUTINE ForceVector_2(test, c, crank, ans, tsize) 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_ !---------------------------------------------------------------------------- @@ -136,13 +152,17 @@ END SUBROUTINE ForceVector_2 ! F(i,I)=\int_{\Omega}c_{i}N^{I}d\Omega ! $$ -INTERFACE ForceVector +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 ForceVector3 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector3 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -161,7 +181,7 @@ END FUNCTION ForceVector3 ! F(i,I)=\int_{\Omega}v_{i}N^{I}d\Omega ! $$ -INTERFACE ForceVector_ +INTERFACE MODULE SUBROUTINE ForceVector_3(test, c, crank, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c @@ -169,6 +189,10 @@ MODULE SUBROUTINE ForceVector_3(test, c, crank, ans, nrow, ncol) 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_ !---------------------------------------------------------------------------- @@ -187,13 +211,17 @@ END SUBROUTINE ForceVector_3 ! F(i,j,I)=\int_{\Omega}c_{ij}N^{I}d\Omega ! $$ -INTERFACE ForceVector +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 ForceVector4 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector4 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -212,15 +240,18 @@ END FUNCTION ForceVector4 ! F(i,j,I)=\int_{\Omega}k_{ij}N^{I}d\Omega ! $$ -INTERFACE ForceVector_ - MODULE SUBROUTINE ForceVector_4(test, c, crank, ans, dim1, dim2, & - dim3) +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_ !---------------------------------------------------------------------------- @@ -239,7 +270,7 @@ END SUBROUTINE ForceVector_4 ! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega ! $$ -INTERFACE ForceVector +INTERFACE MODULE FUNCTION ForceVector5(test, c1, c1rank, c2, c2rank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -249,6 +280,10 @@ MODULE FUNCTION ForceVector5(test, c1, c1rank, c2, c2rank) & TYPE(FEVariableScalar_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:) END FUNCTION ForceVector5 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector5 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -267,7 +302,7 @@ END FUNCTION ForceVector5 ! F_{I}=\int_{\Omega}c_{1}c_{2}N^{I}d\Omega ! $$ -INTERFACE ForceVector_ +INTERFACE MODULE SUBROUTINE ForceVector_5(test, c1, c1rank, c2, c2rank, ans, & tsize) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -278,6 +313,10 @@ MODULE SUBROUTINE ForceVector_5(test, c1, c1rank, c2, c2rank, ans, & 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_ !---------------------------------------------------------------------------- @@ -288,7 +327,7 @@ END SUBROUTINE ForceVector_5 ! date: 20 Jan 2022 ! summary: Force vector -INTERFACE ForceVector +INTERFACE MODULE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -298,6 +337,10 @@ MODULE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) & TYPE(FEVariableVector_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION ForceVector6 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector6 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -308,7 +351,7 @@ END FUNCTION ForceVector6 ! date: 20 Jan 2022 ! summary: Force vector -INTERFACE ForceVector_ +INTERFACE MODULE SUBROUTINE ForceVector_6(test, c1, c1rank, c2, c2rank, ans, & nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -319,6 +362,10 @@ MODULE SUBROUTINE ForceVector_6(test, c1, c1rank, c2, c2rank, ans, & 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_ !---------------------------------------------------------------------------- @@ -337,7 +384,7 @@ END SUBROUTINE ForceVector_6 ! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega ! $$ -INTERFACE ForceVector +INTERFACE MODULE FUNCTION ForceVector7(test, c1, c1rank, c2, c2rank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -347,6 +394,10 @@ MODULE FUNCTION ForceVector7(test, c1, c1rank, c2, c2rank) & TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :) END FUNCTION ForceVector7 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector7 END INTERFACE ForceVector !---------------------------------------------------------------------------- @@ -365,7 +416,7 @@ END FUNCTION ForceVector7 ! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega ! $$ -INTERFACE ForceVector_ +INTERFACE MODULE SUBROUTINE ForceVector_7(test, c1, c1rank, c2, c2rank, ans, & dim1, dim2, dim3) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -376,6 +427,10 @@ MODULE SUBROUTINE ForceVector_7(test, c1, c1rank, c2, c2rank, ans, & 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_ !---------------------------------------------------------------------------- @@ -392,13 +447,17 @@ END SUBROUTINE ForceVector_7 ! F_{I}=\int_{\Omega}\rho N^{I}d\Omega ! $$ -INTERFACE ForceVector +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 !---------------------------------------------------------------------------- @@ -415,7 +474,7 @@ END FUNCTION ForceVector8 ! F_{I}=\int_{\Omega}\rho N^{I}d\Omega ! $$ -INTERFACE ForceVector_ +INTERFACE MODULE SUBROUTINE ForceVector_8(test, c, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), INTENT(IN) :: c(:) @@ -423,6 +482,14 @@ MODULE SUBROUTINE ForceVector_8(test, c, ans, tsize) 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_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE ForceVector_Method diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index d05c185c1..75679f6a0 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -17,9 +17,10 @@ SUBMODULE(ForceVector_Method) Methods USE ReallocateUtility, ONLY: Reallocate -USE ElemshapeData_Method, ONLY: GetInterpolation, GetInterpolation_ -USE ProductUtility, ONLY: OuterProd, OuterProd_ +USE ProductUtility, ONLY: OuterProd_ 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 @@ -47,7 +48,6 @@ REAL(DFP) :: realval INTEGER(I4B) :: ips -! main tsize = test%nns ans(1:tsize) = 0.0_DFP @@ -74,24 +74,23 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector_2 -REAL(DFP), PARAMETER :: one = 1.0_DFP -LOGICAL(LGT), PARAMETER :: no = .FALSE. - -REAL(DFP) :: realval +REAL(DFP) :: realval, T(0), cbar INTEGER(I4B) :: ips tsize = test%nns -ans(1:tsize) = 0.0_DFP + +ans(1:tsize) = math%zero DO ips = 1, test%nips - CALL GetInterpolation_(obj=test, ans=realval, val=c, scale=one, & - addContribution=no, timeIndx=1, spaceIndx=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) - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * realval + 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 - END PROCEDURE ForceVector_2 !---------------------------------------------------------------------------- @@ -113,49 +112,25 @@ MODULE PROCEDURE ForceVector_3 ! Define internal variable -REAL(DFP) :: realval, cbar3(3) -INTEGER(I4B) :: ips, tsize -REAL(DFP), ALLOCATABLE :: cbar(:) -LOGICAL(LGT) :: isok +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 -isok = nrow .GT. 3_I4B -IF (isok) THEN - - ALLOCATE (cbar(nrow)) - DO ips = 1, test%nips - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) - CALL GetInterpolation_(obj=test, val=c, ans=cbar, tsize=tsize, & - scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - - CALL OuterProd_(a=cbar(1:tsize), b=test%N(1:test%nns, ips), & - anscoeff=1.0_DFP, scale=realval, & - ans=ans, nrow=nrow, ncol=ncol) - END DO - - DEALLOCATE (cbar) - -ELSE - - DO ips = 1, test%nips - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) - CALL GetInterpolation_(obj=test, val=c, ans=cbar3, tsize=tsize, & - scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - - CALL OuterProd_(a=cbar3(1:tsize), b=test%N(1:test%nns, ips), & - anscoeff=1.0_DFP, scale=realval, & - ans=ans, nrow=nrow, ncol=ncol) - END DO +DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) -END IF + 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 !---------------------------------------------------------------------------- @@ -177,32 +152,27 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector_4 -! Define internal variable -REAL(DFP), ALLOCATABLE :: cbar(:, :) -REAL(DFP) :: realval -INTEGER(I4B) :: ips, ic, jc +REAL(DFP) :: cbar(3, 3), realval, T(0) +INTEGER(I4B) :: ips, i1, i2, i3 -! main -ic = FEVariableSize(c, 1) -jc = FEVariableSize(c, 2) +dim1 = FEVariableSize(c, 1) +dim2 = FEVariableSize(c, 2) dim3 = test%nns -ans(1:ic, 1:jc, 1:dim3) = 0.0_DFP -ALLOCATE (cbar(ic, jc)) +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP DO ips = 1, test%nips realval = test%js(ips) * test%ws(ips) * test%thickness(ips) - CALL GetInterpolation_(obj=test, val=c, ans=cbar, nrow=ic, & - ncol=jc, scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - - CALL OuterProd_(a=cbar(1:ic, 1:jc), b=test%N(1:test%nns, ips), & - anscoeff=1.0_DFP, scale=realval, & - ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) -END DO -DEALLOCATE (cbar) + 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 !---------------------------------------------------------------------------- @@ -222,27 +192,29 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector_5 -REAL(DFP) :: c1bar, c2bar, realval +REAL(DFP) :: c1bar, c2bar, realval, T(0) INTEGER(I4B) :: ips -! main tsize = test%nns ans(1:tsize) = 0.0_DFP DO ips = 1, test%nips - CALL GetInterpolation_(obj=test, ans=c1bar, val=c1, & - scale=1.0_DFP, addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - CALL GetInterpolation_(obj=test, ans=c2bar, val=c2, & - scale=1.0_DFP, addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) + 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) - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c1bar * c2bar + 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 !---------------------------------------------------------------------------- @@ -250,23 +222,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE ForceVector6 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -INTEGER(I4B) :: ips - -! main -CALL GetInterpolation(obj=test, ans=c1bar, val=c1) -CALL GetInterpolation(obj=test, ans=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test%N, 1)) - -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips), test%N(:, ips)) -END DO - -DEALLOCATE (realval, c1bar, c2bar) +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 !---------------------------------------------------------------------------- @@ -275,61 +236,31 @@ MODULE PROCEDURE ForceVector_6 ! Define internal variable -REAL(DFP), ALLOCATABLE :: c2bar(:) -REAL(DFP) :: c1bar, realval, c2bar3(3) -INTEGER(I4B) :: ips, tsize -LOGICAL(LGT) :: isok +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 -isok = nrow .GT. 3_I4B - -IF (isok) THEN - ALLOCATE (c2bar(nrow)) - DO ips = 1, test%nips - CALL GetInterpolation_(obj=test, val=c2, ans=c2bar, tsize=tsize, & - scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - - CALL GetInterpolation_(obj=test, val=c1, ans=c1bar, & - scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c1bar - - CALL OuterProd_(a=c2bar(1:tsize), b=test%N(1:test%nns, ips), & - anscoeff=1.0_DFP, scale=realval, & - ans=ans, nrow=nrow, ncol=ncol) - END DO - - DEALLOCATE (c2bar) - -ELSE - - DO ips = 1, test%nips - CALL GetInterpolation_(obj=test, val=c2, ans=c2bar3, tsize=tsize, & - scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - - CALL GetInterpolation_(obj=test, val=c1, ans=c1bar, & - scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) +DO ips = 1, test%nips - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c1bar + 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 OuterProd_(a=c2bar3(1:tsize), b=test%N(1:test%nns, ips), & - anscoeff=1.0_DFP, scale=realval, & - ans=ans, nrow=nrow, ncol=ncol) - END DO + 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) -END IF + 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 !---------------------------------------------------------------------------- @@ -354,36 +285,33 @@ MODULE PROCEDURE ForceVector_7 ! Define internal variable -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP) :: realval, c1bar -INTEGER(I4B) :: ips, ic, jc +REAL(DFP) :: c2bar(3, 3), realval, c1bar, T(0) +INTEGER(I4B) :: ips, i1, i2, i3 ! main -ic = FEVariableSize(c2, 1) -jc = FEVariableSize(c2, 2) +dim1 = FEVariableSize(c2, 1) +dim2 = FEVariableSize(c2, 2) dim3 = test%nns -ans(1:ic, 1:jc, 1:dim3) = 0.0_DFP - -ALLOCATE (c2bar(ic, jc)) +ans(1:dim1, 1:dim2, 1:dim3) = math%zero DO ips = 1, test%nips - CALL GetInterpolation_(obj=test, val=c2, ans=c2bar, nrow=ic, & - ncol=jc, scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) - CALL GetInterpolation_(obj=test, val=c1, ans=c1bar, scale=1.0_DFP, & - addContribution=.FALSE., & - timeIndx=1_I4B, spaceIndx=ips) + 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) - realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * 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) - CALL OuterProd_(a=c2bar(1:ic, 1:jc), b=test%N(1:test%nns, ips), & - anscoeff=1.0_DFP, scale=realval, & - ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) -END DO + realval = c1bar * test%js(ips) * test%ws(ips) * test%thickness(ips) -DEALLOCATE (c2bar) + 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 !---------------------------------------------------------------------------- From 913a26ba315c60b8cec4900aaeea40b6ec0a710a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Tue, 25 Nov 2025 13:44:23 +0900 Subject: [PATCH 160/184] Updating STForceVector_ --- .../src/STForceVector_Method.F90 | 46 ++++++++++++++ .../src/STForceVector_Method@Methods.F90 | 62 +++++++++++++++++++ 2 files changed, 108 insertions(+) diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index eb174a318..a20872b24 100644 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -64,6 +64,28 @@ END SUBROUTINE obj_STForceVector_1 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 !---------------------------------------------------------------------------- @@ -107,6 +129,30 @@ END SUBROUTINE obj_STForceVector_2 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index bb3803f0a..242721e76 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -69,6 +69,34 @@ END DO END PROCEDURE obj_STForceVector_1 +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +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 +END PROCEDURE obj_STForceVector_22 + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -117,6 +145,40 @@ END DO END PROCEDURE obj_STForceVector_2 +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +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 +END PROCEDURE obj_STForceVector_23 + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- From 072dae9348c948ad139ab746a3a801ed7090a16b Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 26 Nov 2025 22:19:29 +0900 Subject: [PATCH 161/184] Updating FEVariable NodalVariable --- .../src/FEVariable_NodalVariableMethod.F90 | 211 +++++++++++++++++- ...FEVariable_NodalVariableMethod@Methods.F90 | 152 ++++++++++++- 2 files changed, 354 insertions(+), 9 deletions(-) diff --git a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 index 163b5e663..e15511ea0 100644 --- a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 @@ -127,6 +127,29 @@ END FUNCTION Nodal_Scalar_Time ! 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 @@ -174,6 +197,29 @@ END FUNCTION Nodal_Scalar_SpaceTime2 ! 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 @@ -197,6 +243,29 @@ END FUNCTION Nodal_Vector_Constant ! 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 @@ -309,6 +378,29 @@ END FUNCTION Nodal_Vector_Time2 ! 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 @@ -316,7 +408,7 @@ END FUNCTION Nodal_Vector_Time2 INTERFACE MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) & - & RESULT(obj) + RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :, :) TYPE(FEVariableVector_), INTENT(IN) :: rank @@ -356,6 +448,29 @@ END FUNCTION Nodal_Vector_SpaceTime2 ! 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 @@ -363,7 +478,7 @@ END FUNCTION Nodal_Vector_SpaceTime2 INTERFACE MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) & - & RESULT(obj) + RESULT(obj) TYPE(FEVariable_) :: obj REAL(DFP), INTENT(IN) :: val(:, :) TYPE(FEVariableMatrix_), INTENT(IN) :: rank @@ -403,6 +518,29 @@ END FUNCTION Nodal_Matrix_Constant2 ! 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 @@ -448,6 +586,29 @@ END FUNCTION Nodal_Matrix_Space2 ! 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 @@ -493,6 +654,29 @@ END FUNCTION Nodal_Matrix_Time2 ! 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 @@ -536,6 +720,29 @@ END FUNCTION Nodal_Matrix_SpaceTime2 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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 index 698217e43..74f844b55 100644 --- a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 @@ -17,7 +17,6 @@ SUBMODULE(FEVariable_NodalVariableMethod) Methods USE ReallocateUtility, ONLY: Reallocate - USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate IMPLICIT NONE @@ -83,6 +82,19 @@ ! 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) @@ -120,6 +132,22 @@ ! 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 @@ -130,13 +158,26 @@ 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 @@ -185,8 +226,6 @@ CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & vartype=TypeFEVariableOpt%space, & rank=TypeFEVariableOpt%vector, len=tsize) - -obj%val(1:obj%len) = 0.0_DFP END PROCEDURE Nodal_Vector_Space3 !---------------------------------------------------------------------------- @@ -224,13 +263,28 @@ 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) @@ -268,6 +322,23 @@ ! 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 @@ -285,7 +356,6 @@ obj%val(cnt) = val(ii, jj) END DO END DO - END PROCEDURE Nodal_Matrix_Constant !---------------------------------------------------------------------------- @@ -305,6 +375,22 @@ ! 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 @@ -343,6 +429,23 @@ ! 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 @@ -377,13 +480,30 @@ 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 @@ -420,6 +540,24 @@ 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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 5fd059e9ebac80106392bb1f2053020053629d87 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Nov 2025 10:59:30 +0900 Subject: [PATCH 162/184] Updating BaseType Adding defaultVectorSize and defaultMatrixSize in FEVariableOpt --- src/modules/BaseType/src/BaseType.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 80e6224c1..39a4805fe 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -2051,6 +2051,8 @@ END FUNCTION iface_MatrixFunction 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_() From b3929ffc0b60e6d415d0e2b5e02fe4702ac970cf Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Nov 2025 10:59:58 +0900 Subject: [PATCH 163/184] Updating ProductUtility Adding r1r1r2_ method --- src/modules/Utility/src/ProductUtility.F90 | 25 +++++++++++++++++++ .../Utility/src/ProductUtility@Methods.F90 | 16 ++++++++++++ 2 files changed, 41 insertions(+) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index ebd46e0dc..613c8c051 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -650,6 +650,31 @@ END FUNCTION OuterProd_r1r1r2 MODULE PROCEDURE OuterProd_r1r1r2 END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a b c + +INTERFACE + 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 ), 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_ + !---------------------------------------------------------------------------- ! OuterProd !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index d47b1ba06..114873025 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -394,6 +394,22 @@ ! !---------------------------------------------------------------------------- +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_r1r1r3 ans = OuterProd(OuterProd(a, b), c) END PROCEDURE OuterProd_r1r1r3 From 0724fcbba40f7b87a5b8d2c672b93d3b290a8c08 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Nov 2025 11:00:08 +0900 Subject: [PATCH 164/184] Updating MassMatrix --- .../MassMatrix/src/MassMatrix_Method.F90 | 92 +++- src/submodules/MassMatrix/src/MM_1.inc | 52 -- src/submodules/MassMatrix/src/MM_2a.inc | 58 -- src/submodules/MassMatrix/src/MM_2b.inc | 61 --- src/submodules/MassMatrix/src/MM_2c.inc | 59 -- src/submodules/MassMatrix/src/MM_2d.inc | 61 --- src/submodules/MassMatrix/src/MM_3.inc | 62 --- .../src/MassMatrix_Method@Methods.F90 | 504 ++++++++++-------- 8 files changed, 347 insertions(+), 602 deletions(-) delete mode 100644 src/submodules/MassMatrix/src/MM_1.inc delete mode 100644 src/submodules/MassMatrix/src/MM_2a.inc delete mode 100644 src/submodules/MassMatrix/src/MM_2b.inc delete mode 100644 src/submodules/MassMatrix/src/MM_2c.inc delete mode 100644 src/submodules/MassMatrix/src/MM_2d.inc delete mode 100644 src/submodules/MassMatrix/src/MM_3.inc diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index 7b7eeafa6..59bee800b 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -20,9 +20,15 @@ ! 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 @@ -45,7 +51,7 @@ MODULE MassMatrix_Method ! $$\int_{\Omega } N^{I} N^{J}d\Omega$$ ! -INTERFACE MassMatrix +INTERFACE MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function @@ -55,13 +61,17 @@ 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 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE MassMatrix_ +INTERFACE MODULE PURE SUBROUTINE MassMatrix1_(test, trial, ans, nrow, ncol, opt) CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial @@ -69,6 +79,10 @@ MODULE PURE SUBROUTINE MassMatrix1_(test, trial, ans, nrow, ncol, opt) INTEGER(I4B), INTENT(OUT) :: nrow, ncol INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt END SUBROUTINE MassMatrix1_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix1_ END INTERFACE MassMatrix_ !---------------------------------------------------------------------------- @@ -79,9 +93,9 @@ END SUBROUTINE MassMatrix1_ ! date: 6 March 2021 ! summary: This subroutine makes mass matrix in space domain -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 @@ -93,13 +107,17 @@ 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 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE MassMatrix_ +INTERFACE MODULE PURE SUBROUTINE MassMatrix2_(test, trial, rho, rhorank, & ans, nrow, ncol, opt) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -110,6 +128,10 @@ MODULE PURE SUBROUTINE MassMatrix2_(test, trial, rho, rhorank, & 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_ !---------------------------------------------------------------------------- @@ -120,20 +142,25 @@ END SUBROUTINE MassMatrix2_ ! date: 6 March 2021 ! summary: This subroutine makes mass matrix in space domain -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 !---------------------------------------------------------------------------- @@ -145,9 +172,8 @@ END FUNCTION MassMatrix_3 ! summary: mass matrix in space ! notice: not implemented yet -INTERFACE MassMatrix_ - MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, & - opt, nrow, ncol, ans) +INTERFACE + MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, opt, nrow, ncol, ans) CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial CLASS(FEVariable_), INTENT(IN) :: rho @@ -155,6 +181,10 @@ MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol REAL(DFP), INTENT(INOUT) :: ans(:, :) END SUBROUTINE MassMatrix3_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix3_ END INTERFACE MassMatrix_ !---------------------------------------------------------------------------- @@ -165,18 +195,23 @@ END SUBROUTINE MassMatrix3_ ! 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 !---------------------------------------------------------------------------- @@ -188,16 +223,27 @@ END FUNCTION MassMatrix_4 ! summary: mass matrix in space ! notice: not implemented yet -INTERFACE MassMatrix_ - MODULE PURE SUBROUTINE MassMatrix4_(test, trial, rho, rhorank, & - nrow, ncol, ans) +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 - INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! 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_ !---------------------------------------------------------------------------- @@ -208,9 +254,9 @@ END SUBROUTINE MassMatrix4_ ! date: 2024-01-15 ! summary: This subroutine makes mass matrix used for viscous boundary -INTERFACE ViscousBoundaryMassMatrix +INTERFACE MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & - & RESULT(ans) + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function CLASS(ElemshapeData_), INTENT(IN) :: trial @@ -223,6 +269,10 @@ MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & !! Mass Density REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION MassMatrix_5 +END INTERFACE + +INTERFACE ViscousBoundaryMassMatrix + MODULE PROCEDURE MassMatrix_5 END INTERFACE ViscousBoundaryMassMatrix !---------------------------------------------------------------------------- diff --git a/src/submodules/MassMatrix/src/MM_1.inc b/src/submodules/MassMatrix/src/MM_1.inc deleted file mode 100644 index f286982d8..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, ans=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 d89b3e59f..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, 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_2a diff --git a/src/submodules/MassMatrix/src/MM_2b.inc b/src/submodules/MassMatrix/src/MM_2b.inc deleted file mode 100644 index a8532fe26..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, 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_2b diff --git a/src/submodules/MassMatrix/src/MM_2c.inc b/src/submodules/MassMatrix/src/MM_2c.inc deleted file mode 100644 index a0631a864..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, 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_2c diff --git a/src/submodules/MassMatrix/src/MM_2d.inc b/src/submodules/MassMatrix/src/MM_2d.inc deleted file mode 100644 index 11d395eed..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, 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_2d diff --git a/src/submodules/MassMatrix/src/MM_3.inc b/src/submodules/MassMatrix/src/MM_3.inc deleted file mode 100644 index 071263c47..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, ans=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 44469b204..eb3e9cd29 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -16,7 +16,22 @@ ! 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 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,176 +39,15 @@ ! 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, 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_2a - -!---------------------------------------------------------------------------- -! 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, 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_2b - -!---------------------------------------------------------------------------- -! 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, 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_2c - -!---------------------------------------------------------------------------- -! 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, 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_2d - -!---------------------------------------------------------------------------- -! 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 - -DO ips = 1, SIZE(trial%N, 2) - ans = ans + realval(ips) * & - & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) -END DO - -IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt) -DEALLOCATE (realval) +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 !---------------------------------------------------------------------------- @@ -201,29 +55,29 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE Massmatrix1_ -REAL(DFP), PARAMETER :: one = 1.0_DFP REAL(DFP) :: realval -INTEGER(I4B) :: ii, jj, ips +INTEGER(I4B) :: ii, jj, ips, opt0 +LOGICAL(LGT) :: isok nrow = test%nns ncol = trial%nns -ans(1:nrow, 1:ncol) = 0.0 +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=one) - + 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 -IF (PRESENT(opt)) THEN - CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) - nrow = opt * nrow - ncol = opt * ncol +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_ !---------------------------------------------------------------------------- @@ -231,21 +85,14 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix_2 -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips - -! main -CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) -CALL GetInterpolation(obj=trial, ans=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) +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 !---------------------------------------------------------------------------- @@ -253,31 +100,35 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix2_ -REAL(DFP) :: realval(trial%nips) -REAL(DFP), PARAMETER :: one = 1.0_DFP -INTEGER(I4B) :: ips, ii, jj -LOGICAL(LGT) :: isopt +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 -realval = 0.0_DFP -CALL GetInterpolation_(obj=trial, ans=realval, val=rho, tsize=ii) -realval = trial%js * trial%ws * trial%thickness * realval +ans(1:nrow * opt0, 1:ncol * opt0) = math%zero DO ips = 1, test%nips - CALL OuterProd_(a=test%N(1:nrow, ips), & - b=trial%N(1:ncol, ips), & - nrow=ii, ncol=jj, ans=ans, scale=realval(ips), & - anscoeff=one) + + 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) + + realval = rhobar * trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + + 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 -isopt = PRESENT(opt) -IF (isopt) THEN - CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) - nrow = opt * nrow - ncol = opt * ncol +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_ !---------------------------------------------------------------------------- @@ -285,25 +136,191 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- 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 +! 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 !---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +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 +!---------------------------------------------------------------------------- + +! 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 + +!---------------------------------------------------------------------------- +! MassMatrix !---------------------------------------------------------------------------- -MODULE PROCEDURE massmatrix3_ -! TODO: implement -END PROCEDURE massmatrix3_ +! 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 + +!---------------------------------------------------------------------------- +! 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 +!---------------------------------------------------------------------------- + +! 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 @@ -342,7 +359,38 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix4_ -! TODO: implement +INTEGER(I4B) :: ii, jj, ips, rhobar_i, rhobar_j, nns1, nns2 +INTEGER(I4B) :: i1, i2, i3, i4 +REAL(DFP) :: realval, T(0), scale, & + rhobar(varopt%defaultMatrixSize, varopt%defaultMatrixSize) + +! main + +rhobar_i = FEVariableSize(obj=rho, dim=1) +rhobar_j = FEVariableSize(obj=rho, dim=2) + +nns1 = test%nns +nns2 = trial%nns + +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(1:nns1, 1:nns2, 1:rhobar_i, 1:rhobar_j), & + to=ans, nrow=nrow, ncol=ncol) END PROCEDURE MassMatrix4_ !---------------------------------------------------------------------------- From 374c8a2526b2d6edcaa83820305749fe557efd1f Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Nov 2025 11:54:26 +0900 Subject: [PATCH 165/184] Updating MassMatrix Still some routines needs to be updated --- .../MassMatrix/src/MassMatrix_Method.F90 | 105 +++++++++++++++--- .../src/MassMatrix_Method@Methods.F90 | 88 +++++++++++---- 2 files changed, 152 insertions(+), 41 deletions(-) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index 59bee800b..08ed6d163 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -41,15 +41,7 @@ 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 MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) @@ -71,13 +63,29 @@ END FUNCTION MassMatrix_1 ! !---------------------------------------------------------------------------- +!> 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 @@ -91,7 +99,7 @@ END SUBROUTINE MassMatrix1_ !> 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 MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) & @@ -117,6 +125,17 @@ END FUNCTION MassMatrix_2 ! !---------------------------------------------------------------------------- +!> 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) @@ -140,7 +159,7 @@ END SUBROUTINE MassMatrix2_ !> 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 MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) & @@ -167,16 +186,28 @@ END FUNCTION MassMatrix_3 ! !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-02 -! summary: mass matrix in space -! notice: not implemented yet +!> 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, opt, nrow, ncol, ans) + 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(:, :) @@ -232,7 +263,7 @@ MODULE PURE SUBROUTINE MassMatrix4_( & !! FEVariable TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank !! Matrix FEVariable - REAL(DFP), INTENT(INOUT) :: m4(:, :, :, :) + 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(:, :) @@ -255,7 +286,8 @@ END SUBROUTINE MassMatrix4_ ! summary: This subroutine makes mass matrix used for viscous boundary INTERFACE - MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & + MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho, & + lambdaRank, muRank, rhoRank) & RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function @@ -267,14 +299,51 @@ 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index eb3e9cd29..c1f02b0e5 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -327,31 +327,22 @@ !---------------------------------------------------------------------------- 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 -! main -CALL GetInterpolation(obj=trial, ans=kbar, val=rho) -CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2)) +rhobar_i = FEVariableSize(obj=rho, dim=1) +rhobar_j = FEVariableSize(obj=rho, dim=2) +nns1 = test%nns +nns2 = trial%nns -realval = trial%js * trial%ws * trial%thickness +CALL Reallocate(m4, nns1, nns2, rhobar_i, rhobar_j) +CALL Reallocate(ans, nns1 * rhobar_i, nns2 * rhobar_j) -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 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 -CALL Convert(From=m4, To=ans) -DEALLOCATE (realval, m2, kbar, m4) +DEALLOCATE (m4) END PROCEDURE MassMatrix_4 !---------------------------------------------------------------------------- @@ -359,19 +350,21 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix4_ -INTEGER(I4B) :: ii, jj, ips, rhobar_i, rhobar_j, nns1, nns2 +INTEGER(I4B) :: ips, rhobar_i, rhobar_j, nns1, nns2 INTEGER(I4B) :: i1, i2, i3, i4 -REAL(DFP) :: realval, T(0), scale, & +REAL(DFP) :: realval, T(0), & rhobar(varopt%defaultMatrixSize, varopt%defaultMatrixSize) ! main rhobar_i = FEVariableSize(obj=rho, dim=1) rhobar_j = FEVariableSize(obj=rho, dim=2) - nns1 = test%nns nns2 = trial%nns +! 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 @@ -445,6 +438,55 @@ & 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From f78f87f48df55774700916d16381a44fca139721 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Nov 2025 12:10:33 +0900 Subject: [PATCH 166/184] Updating Massmatrix Adding a simple massmatrix method --- .../MassMatrix/src/MassMatrix_Method.F90 | 34 +++++++++++++++++++ .../src/MassMatrix_Method@Methods.F90 | 21 ++++++++++++ 2 files changed, 55 insertions(+) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index 08ed6d163..5f27831bc 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -344,6 +344,40 @@ END SUBROUTINE MassMatrix5_ 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index c1f02b0e5..4bb92d565 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -491,4 +491,25 @@ ! !---------------------------------------------------------------------------- +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_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END SUBMODULE Methods From cff9b2678b48544b6f2dd93909e3a46b1081ec89 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 27 Nov 2025 12:11:33 +0900 Subject: [PATCH 167/184] Updatin ConvectiveMatrix putting include files in include dir with .F90 ext --- .../src/ConvectiveMatrix_Method@Methods.F90 | 24 ++++++++++--------- .../src/{CM_1.inc => include/CM_1.F90} | 0 .../src/{CM_10.inc => include/CM_10.F90} | 0 .../src/{CM_2.inc => include/CM_2.F90} | 0 .../src/{CM_3.inc => include/CM_3.F90} | 0 .../src/{CM_4.inc => include/CM_4.F90} | 0 .../src/{CM_5.inc => include/CM_5.F90} | 0 .../src/{CM_6.inc => include/CM_6.F90} | 0 .../src/{CM_7.inc => include/CM_7.F90} | 0 .../src/{CM_8.inc => include/CM_8.F90} | 0 .../src/{CM_9.inc => include/CM_9.F90} | 0 11 files changed, 13 insertions(+), 11 deletions(-) rename src/submodules/ConvectiveMatrix/src/{CM_1.inc => include/CM_1.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_10.inc => include/CM_10.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_2.inc => include/CM_2.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_3.inc => include/CM_3.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_4.inc => include/CM_4.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_5.inc => include/CM_5.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_6.inc => include/CM_6.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_7.inc => include/CM_7.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_8.inc => include/CM_8.F90} (100%) rename src/submodules/ConvectiveMatrix/src/{CM_9.inc => include/CM_9.F90} (100%) diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 index 6c2dcb8aa..2cefe0534 100644 --- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 +++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 @@ -19,16 +19,16 @@ 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 @@ -197,7 +197,7 @@ PURE SUBROUTINE CM1_(ans, test, trial, c, term1, term2, opt, nrow, ncol) 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), & @@ -515,6 +515,8 @@ PURE SUBROUTINE CM9_(ans, test, trial, term1, term2, opt, nrow, ncol) 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 diff --git a/src/submodules/ConvectiveMatrix/src/CM_1.inc b/src/submodules/ConvectiveMatrix/src/include/CM_1.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_1.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_1.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/include/CM_10.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_10.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_10.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_2.inc b/src/submodules/ConvectiveMatrix/src/include/CM_2.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_2.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_2.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_3.inc b/src/submodules/ConvectiveMatrix/src/include/CM_3.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_3.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_3.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_4.inc b/src/submodules/ConvectiveMatrix/src/include/CM_4.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_4.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_4.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/include/CM_5.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_5.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_5.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/include/CM_6.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_6.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_6.F90 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 100% rename from src/submodules/ConvectiveMatrix/src/CM_9.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_9.F90 From 7e47913e76c84363f04a7d797c338365a9f13c9a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 28 Nov 2025 16:41:45 +0900 Subject: [PATCH 168/184] Updating dof method Updating display method --- src/modules/DOF/src/DOF_IOMethods.F90 | 5 +- src/modules/Display/src/Display_Method.F90 | 179 +++++++++--------- .../Display_Mat2.F90} | 0 .../Display_Mat3.F90} | 0 .../Display_Mat4.F90} | 0 .../Display_Scalar.F90} | 0 .../Display_Vector.F90} | 6 +- .../DOF/src/DOF_IOMethods@Methods.F90 | 50 ++--- 8 files changed, 125 insertions(+), 115 deletions(-) rename src/modules/Display/src/{Display_Mat2.inc => include/Display_Mat2.F90} (100%) rename src/modules/Display/src/{Display_Mat3.inc => include/Display_Mat3.F90} (100%) rename src/modules/Display/src/{Display_Mat4.inc => include/Display_Mat4.F90} (100%) rename src/modules/Display/src/{Display_Scalar.inc => include/Display_Scalar.F90} (100%) rename src/modules/Display/src/{Display_Vector.inc => include/Display_Vector.F90} (92%) 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/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90 index c516de534..7db090a23 100755 --- a/src/modules/Display/src/Display_Method.F90 +++ b/src/modules/Display/src/Display_Method.F90 @@ -61,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 @@ -266,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 !---------------------------------------------------------------------------- @@ -293,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 !---------------------------------------------------------------------------- @@ -316,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 !---------------------------------------------------------------------------- @@ -339,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 !---------------------------------------------------------------------------- @@ -366,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 !---------------------------------------------------------------------------- @@ -393,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 !---------------------------------------------------------------------------- @@ -420,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 !---------------------------------------------------------------------------- @@ -447,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 !---------------------------------------------------------------------------- @@ -530,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 !---------------------------------------------------------------------------- @@ -568,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 !---------------------------------------------------------------------------- @@ -605,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 !---------------------------------------------------------------------------- @@ -643,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 !---------------------------------------------------------------------------- @@ -680,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 !---------------------------------------------------------------------------- @@ -718,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 !---------------------------------------------------------------------------- @@ -756,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 !---------------------------------------------------------------------------- @@ -793,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 !---------------------------------------------------------------------------- @@ -830,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 !---------------------------------------------------------------------------- @@ -857,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 !---------------------------------------------------------------------------- @@ -884,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 !---------------------------------------------------------------------------- @@ -912,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 !---------------------------------------------------------------------------- @@ -940,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 !---------------------------------------------------------------------------- @@ -965,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 !---------------------------------------------------------------------------- @@ -990,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 !---------------------------------------------------------------------------- @@ -1015,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 !---------------------------------------------------------------------------- @@ -1040,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 !---------------------------------------------------------------------------- @@ -1065,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 !---------------------------------------------------------------------------- @@ -1094,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 !---------------------------------------------------------------------------- @@ -1123,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 !---------------------------------------------------------------------------- @@ -1153,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 !---------------------------------------------------------------------------- @@ -1183,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 !---------------------------------------------------------------------------- @@ -1212,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 !---------------------------------------------------------------------------- @@ -1241,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 !---------------------------------------------------------------------------- @@ -1271,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 !---------------------------------------------------------------------------- @@ -1301,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 !---------------------------------------------------------------------------- @@ -1331,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 !---------------------------------------------------------------------------- @@ -1361,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 !---------------------------------------------------------------------------- @@ -1392,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 !---------------------------------------------------------------------------- @@ -1422,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 !---------------------------------------------------------------------------- @@ -1452,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 !---------------------------------------------------------------------------- @@ -1482,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 !---------------------------------------------------------------------------- @@ -1512,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 !---------------------------------------------------------------------------- @@ -1542,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 !---------------------------------------------------------------------------- @@ -1708,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/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 92% rename from src/modules/Display/src/Display_Vector.inc rename to src/modules/Display/src/include/Display_Vector.F90 index 897509be8..48f6fd087 100644 --- a/src/modules/Display/src/Display_Vector.inc +++ b/src/modules/Display/src/include/Display_Vector.F90 @@ -52,9 +52,9 @@ IF (full_ .OR. ss .LE. (minRow + minRow)) 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 diff --git a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 index 053ad9e57..28c267832 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 @@ -32,36 +36,36 @@ INTEGER(I4B) :: n, j LOGICAL(LGT) :: isok -CALL Display(msg, unitNo=unitNo) +CALL MyDisplay(msg, unitNo=unitNo) isok = ALLOCATED(obj%map) -CALL Display(isok, "obj%map allocated: ", UnitNo=UnitNo) +CALL MyDisplay(isok, "obj%map allocated: ", UnitNo=UnitNo) IF (.NOT. isok) RETURN n = SIZE(obj%map, 1) - 1 -CALL Display(n, "Total Physical Variables :", unitNo=unitNo) +CALL MyDisplay(n, "Total Physical Variables :", unitNo=unitNo) DO j = 1, n - CALL Display("Name : "//CHAR(obj%map(j, 1)), unitNo=unitNo) + CALL MyDisplay("Name : "//CHAR(obj%map(j, 1)), unitNo=unitNo) IF (obj%map(j, 2) .LT. 0) THEN - CALL Display("Space Components : "//"Scalar", unitNo=unitNo) + CALL MyDisplay("Space Components : "//"Scalar", unitNo=unitNo) ELSE - CALL Display(obj%map(j, 2), "Space Components : ", unitNo=unitNo) + CALL MyDisplay(obj%map(j, 2), "Space Components : ", unitNo=unitNo) END IF - CALL Display(obj%map(j, 3), "Time Components : ", unitNo=unitNo) - CALL Display(obj%map(j, 6), "Total Nodes : ", unitNo=unitNo) + 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 (DOF_FMT) - CALL Display("Storage Format : DOF", unitNo=unitNo) -CASE (Nodes_FMT) - CALL Display("Storage Format : Nodes", unitNo=unitNo) +CASE (FMT_DOF) + CALL MyDisplay("Storage Format : DOF", unitNo=unitNo) +CASE (FMT_NODES) + CALL MyDisplay("Storage Format : Nodes", unitNo=unitNo) END SELECT -CALL Display(obj%valmap, "Value map : ", unitNo=unitNo) +CALL MyDisplay(obj%valmap, "Value map : ", unitNo=unitNo) END PROCEDURE dof_Display1 @@ -69,7 +73,7 @@ ! Display !---------------------------------------------------------------------------- -MODULE PROCEDURE dof_display2 +MODULE PROCEDURE dof_Display2 INTEGER(I4B) :: jj, tnames, idof, a(3) !> main CALL Display(obj, 'DOF data : ', unitNo=unitNo) @@ -77,25 +81,25 @@ 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") 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 From 446c809894f0822a4c138e8edd5f8c76473a5b2c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 29 Nov 2025 17:10:49 +0900 Subject: [PATCH 169/184] Updating Display Method --- .../Display/src/include/Display_Vector.F90 | 51 +++++++++---------- .../DOF/src/DOF_IOMethods@Methods.F90 | 5 +- 2 files changed, 27 insertions(+), 29 deletions(-) diff --git a/src/modules/Display/src/include/Display_Vector.F90 b/src/modules/Display/src/include/Display_Vector.F90 index 48f6fd087..8b087060c 100644 --- a/src/modules/Display/src/include/Display_Vector.F90 +++ b/src/modules/Display/src/include/Display_Vector.F90 @@ -19,37 +19,30 @@ 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, & @@ -58,16 +51,20 @@ #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/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 index 28c267832..7c7d17d14 100644 --- a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 +++ b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 @@ -85,8 +85,9 @@ DO idof = obj%Map(jj, 5), obj%Map(jj + 1, 5) - 1 a = GetNodeLoc(obj=obj, idof=idof) - CALL MyDisplay(Vec(a(1):a(2):a(3)), & - msg="DOF-"//ToString(idof), unitNo=unitNo, advance="NO") + CALL MyDisplay( & + vec(a(1):a(2):a(3)), msg="DOF-"//ToString(idof), unitNo=unitNo, & + advance="NO", full=.TRUE.) END DO CALL MyDisplay(" ", unitNo=unitNo, advance=.TRUE.) END DO From 4602cc2fd2082a77fd003f7f25c7fffb0e1a1304 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 14:03:48 +0900 Subject: [PATCH 170/184] Adding ProjectionMethod --- src/modules/CMakeLists.txt | 3 + src/modules/Projection/CMakeLists.txt | 19 ++++ .../Projection/src/Projection_Method.F90 | 73 +++++++++++++ src/submodules/CMakeLists.txt | 3 + src/submodules/Projection/CMakeLists.txt | 20 ++++ .../src/Projection_Method@L2Methods.F90 | 102 ++++++++++++++++++ 6 files changed, 220 insertions(+) create mode 100644 src/modules/Projection/CMakeLists.txt create mode 100644 src/modules/Projection/src/Projection_Method.F90 create mode 100644 src/submodules/Projection/CMakeLists.txt create mode 100644 src/submodules/Projection/src/Projection_Method@L2Methods.F90 diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 2a7bd314a..073cd78ae 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -215,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/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..ce6069c38 --- /dev/null +++ b/src/modules/Projection/src/Projection_Method.F90 @@ -0,0 +1,73 @@ +! 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 + +!---------------------------------------------------------------------------- +! L2Projection +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-12-01 +! summary: L2 Projection method to get DOF values + +INTERFACE + MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature( & + elemsd, func, ans, tsize, massMat, ipiv, onlyFaceBubble, 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), OPTIONAL, INTENT(IN) :: onlyFaceBubble + !! if true then we include only face bubble, that is, + !! only include internal face bubble. + INTEGER(I4B), OPTIONAL, INTENT(IN) :: tVertices + !! tVertices are needed when onlyFaceBubble is true + !! tVertices are total number of vertex degree of + !! freedom + END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature +END INTERFACE + +INTERFACE GetL2ProjectionDOFValueFromQuadrature + MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature +END INTERFACE GetL2ProjectionDOFValueFromQuadrature + +END MODULE Projection_Method diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index f0eb632a9..ac3d6e7fb 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -141,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/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..075a0e31f --- /dev/null +++ b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 @@ -0,0 +1,102 @@ +! 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 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_GetL2ProjectionDOFValueFromQuadrature +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature()" +LOGICAL(LGT) :: isok +#endif + +INTEGER(I4B) :: info, nrow, ncol, n1, n2, ii, nns +LOGICAL(LGT) :: onlyFaceBubble0 + +onlyFaceBubble0 = Input(option=onlyFaceBubble, default=math%no) + +#ifdef DEBUG_VER +IF (onlyFaceBubble0) THEN + isok = PRESENT(tVertices) + CALL AssertError1(isok, myName, modName, __LINE__, & + 'tVertices must be provided when onlyFaceBubble is true') +END IF +#endif + +nns = elemsd%nns + +#ifdef DEBUG_VER +n1 = SIZE(func) +isok = n1 .GE. elemsd%nns +CALL AssertError1(isok, myName, modName, __LINE__, & + 'Size of func='//ToString(n1)//' is lesser than elemsd%nns='// & + ToString(elemsd%nns)) +#endif + +massMat(1:nns, 1:nns) = 0.0_DFP + +n1 = 1; n2 = nns + +IF (onlyFaceBubble0) THEN + n1 = tVertices + 1; n2 = nns +END IF + +tsize = n2 - n1 + 1 + +CALL MassMatrix_(test=elemsd, trial=elemsd, ans=massMat, & + nrow=nrow, ncol=ncol) + +CALL ForceVector_(test=elemsd, c=func, ans=ans, tsize=nrow) + +CALL GetLU(A=massMat(n1:n2, n1:n2), IPIV=ipiv(n1:n2), info=info) + +CALL LUSolve(A=massMat(n1:n2, n1:n2), B=ans(n1:n2), & + IPIV=ipiv(n1:n2), info=info) + +IF (onlyFaceBubble0) THEN + DO ii = tVertices + 1, nns + ans(ii - 2) = ans(ii) + END DO +END IF +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE L2Methods + From 4480c6313d9efaef613af87d0a7d5fa443f59b7c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 16:31:09 +0900 Subject: [PATCH 171/184] Updating MassMatrix Adding new mass matrices --- .../MassMatrix/src/MassMatrix_Method.F90 | 128 ++++++++++++++++++ .../src/MassMatrix_Method@Methods.F90 | 118 +++++++++++++++- 2 files changed, 241 insertions(+), 5 deletions(-) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index 5f27831bc..0df47bdf9 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -378,6 +378,134 @@ END SUBROUTINE MassMatrix6_ 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, spaceMat, timeMat, 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) :: spaceMat(:, :) + !! space mass matrix, it will be formed internally + !! size should be at least nns1 x nns2 + REAL(DFP), INTENT(INOUT) :: timeMat(:, :) + !! time mass matrix, it will be formed internally + !! size should be at least nnt1 x nnt2 + 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, spaceMat, timeMat, & + 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 + REAL(DFP), INTENT(INOUT) :: spaceMat(:, :) + !! space mass matrix, it will be formed internally + !! size should be at least nns1 x nns2 + REAL(DFP), INTENT(INOUT) :: timeMat(:, :) + !! time mass matrix, it will be formed internally + !! size should be at least nnt1 x nnt2 + 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/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 4bb92d565..5366f9152 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -19,8 +19,9 @@ 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: OuterProd +USE ProductUtility, ONLY: OTimesTilda USE ConvertUtility, ONLY: Convert USE ConvertUtility, ONLY: Convert_ USE RealMatrix_Method, ONLY: MakeDiagonalCopies @@ -54,7 +55,7 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE Massmatrix1_ +MODULE PROCEDURE MassMatrix1_ REAL(DFP) :: realval INTEGER(I4B) :: ii, jj, ips, opt0 LOGICAL(LGT) :: isok @@ -78,7 +79,7 @@ nrow = opt0 * nrow ncol = opt0 * ncol END IF -END PROCEDURE Massmatrix1_ +END PROCEDURE MassMatrix1_ !---------------------------------------------------------------------------- ! MassMatrix @@ -491,7 +492,7 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE Massmatrix6_ +MODULE PROCEDURE MassMatrix6_ REAL(DFP) :: realval INTEGER(I4B) :: ii, jj, ips @@ -506,7 +507,114 @@ 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_ +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) :: spaceRow, spaceCol, timeRow, timeCol + +CALL MassMatrix_( & + N=spaceN, M=spaceM, js=js, ws=ws, thickness=spaceThickness, nips=nips, & + nns1=nns1, nns2=nns2, ans=spaceMat, nrow=spaceRow, ncol=spaceCol) + +CALL MassMatrix_( & + N=timeN, M=timeM, js=jt, ws=wt, thickness=timeThickness, nips=nipt, & + nns1=nnt1, nns2=nnt2, ans=timeMat, nrow=timeRow, ncol=timeCol) + +CALL OTimesTilda(a=spaceMat(1:spaceRow, 1:spaceCol), & + b=timeMat(1:timeRow, 1:timeCol), & + ans=ans, nrow=nrow, ncol=ncol, & + anscoeff=math%zero, scale=math%one) + +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, spaceMat=spaceMat, timeMat=timeMat, & + 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, spaceMat=spaceMat, timeMat=timeMat, & + ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE MassMatrix9_ !---------------------------------------------------------------------------- ! From 5278600dc7099997994b4cbc03b61132c150f1bb Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 17:15:44 +0900 Subject: [PATCH 172/184] Updating ForceVector --- .../ForceVector/src/ForceVector_Method.F90 | 129 ++++++++++++++++++ .../src/ForceVector_Method@Methods.F90 | 107 +++++++++++++++ 2 files changed, 236 insertions(+) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 3a8368b23..3d74509f2 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -488,6 +488,135 @@ END SUBROUTINE ForceVector_8 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index 75679f6a0..9ce2647d2 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -18,6 +18,7 @@ SUBMODULE(ForceVector_Method) Methods 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 @@ -343,6 +344,112 @@ END DO END PROCEDURE ForceVector_8 +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_9 +! Define internal variable +INTEGER(I4B) :: ips +REAL(DFP) :: realval + +tsize = nns +ans(1:tsize) = 0.0_DFP + +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 + +!---------------------------------------------------------------------------- +! 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_ +!---------------------------------------------------------------------------- + +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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 2b8a5a6fa53cc726aee94df5972bce9fe8c331d6 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 17:16:00 +0900 Subject: [PATCH 173/184] Updating Projection --- .../Projection/src/Projection_Method.F90 | 60 +++++++++++++-- .../src/Projection_Method@L2Methods.F90 | 77 ++++++++++++++----- 2 files changed, 112 insertions(+), 25 deletions(-) diff --git a/src/modules/Projection/src/Projection_Method.F90 b/src/modules/Projection/src/Projection_Method.F90 index ce6069c38..15af1edf2 100644 --- a/src/modules/Projection/src/Projection_Method.F90 +++ b/src/modules/Projection/src/Projection_Method.F90 @@ -41,8 +41,8 @@ MODULE Projection_Method ! summary: L2 Projection method to get DOF values INTERFACE - MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature( & - elemsd, func, ans, tsize, massMat, ipiv, onlyFaceBubble, tVertices) + 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(:) @@ -56,18 +56,66 @@ MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature( & !! mass matrix INTEGER(I4B), INTENT(INOUT) :: ipiv(:) !! pivot indices for LU decomposition of mass matrix - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: onlyFaceBubble + LOGICAL(LGT), INTENT(IN) :: skipVertices !! if true then we include only face bubble, that is, !! only include internal face bubble. - INTEGER(I4B), OPTIONAL, INTENT(IN) :: tVertices + INTEGER(I4B), INTENT(IN) :: tVertices !! tVertices are needed when onlyFaceBubble is true !! tVertices are total number of vertex degree of !! freedom - END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature + END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1 END INTERFACE INTERFACE GetL2ProjectionDOFValueFromQuadrature - MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature + MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 +END INTERFACE GetL2ProjectionDOFValueFromQuadrature + +!---------------------------------------------------------------------------- +! L2Projection +!---------------------------------------------------------------------------- + +!> 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, nrow, ncol, 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 + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! 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 END MODULE Projection_Method diff --git a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 index 075a0e31f..4404a20e2 100644 --- a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 +++ b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 @@ -36,40 +36,29 @@ ! GetL2ProjectionDOFValueFromQuadrature !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature +MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 #ifdef DEBUG_VER -CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature()" +CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature1()" LOGICAL(LGT) :: isok #endif INTEGER(I4B) :: info, nrow, ncol, n1, n2, ii, nns -LOGICAL(LGT) :: onlyFaceBubble0 - -onlyFaceBubble0 = Input(option=onlyFaceBubble, default=math%no) - -#ifdef DEBUG_VER -IF (onlyFaceBubble0) THEN - isok = PRESENT(tVertices) - CALL AssertError1(isok, myName, modName, __LINE__, & - 'tVertices must be provided when onlyFaceBubble is true') -END IF -#endif nns = elemsd%nns #ifdef DEBUG_VER n1 = SIZE(func) -isok = n1 .GE. elemsd%nns +isok = n1 .GE. elemsd%nips CALL AssertError1(isok, myName, modName, __LINE__, & - 'Size of func='//ToString(n1)//' is lesser than elemsd%nns='// & - ToString(elemsd%nns)) + 'Size of func='//ToString(n1)//' is lesser than elemsd%nips='// & + ToString(elemsd%nips)) #endif massMat(1:nns, 1:nns) = 0.0_DFP n1 = 1; n2 = nns -IF (onlyFaceBubble0) THEN +IF (skipVertices) THEN n1 = tVertices + 1; n2 = nns END IF @@ -85,12 +74,62 @@ CALL LUSolve(A=massMat(n1:n2, n1:n2), B=ans(n1:n2), & IPIV=ipiv(n1:n2), info=info) -IF (onlyFaceBubble0) THEN +IF (skipVertices) THEN DO ii = tVertices + 1, nns ans(ii - 2) = ans(ii) END DO END IF -END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature +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) :: nns, nnt, tdof, i1, i2, j1, j2, info + +nrow = 0 +ncol = 0 + +#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 + +nns = elemsd%nns +nnt = timeElemsd%nns +tdof = nns * nnt + +massMat(1:tdof, 1:tdof) = 0.0_DFP + +i1 = 1; i2 = nnt +j1 = 1; j2 = nnt + +! Make space-time mass matrix and force vector + +CALL GetLU(A=massMat(1:tdof, 1:tdof), IPIV=ipiv(1:tdof), info=info) + +! CALL LUSolve(A=massMat(1:tdof, 1:tdof), B=ans(1:tdof), & +! IPIV=ipiv(1:tdof), info=info) + +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2 !---------------------------------------------------------------------------- ! Include error From 27c19763eb868b32c1a4d31c1dc340eeaf18fa4c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 17:16:06 +0900 Subject: [PATCH 174/184] Updating ProductUtility --- src/modules/Utility/src/ProductUtility.F90 | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index 613c8c051..f372d7dd6 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -25,6 +25,7 @@ MODULE ProductUtility PUBLIC :: OuterProd PUBLIC :: OuterProd_ PUBLIC :: OTimesTilda +PUBLIC :: OTimesTilda_ PUBLIC :: Cross_Product PUBLIC :: Vector_Product PUBLIC :: VectorProduct @@ -38,10 +39,13 @@ MODULE ProductUtility ! summary: returns a space-time matrix from time and space matrix INTERFACE - MODULE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale) + 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 @@ -52,16 +56,20 @@ END SUBROUTINE OTimesTilda1 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 +! summary: returns a space-time vector from time and space vector INTERFACE - MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) + 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(:) @@ -75,6 +83,10 @@ END SUBROUTINE OTimesTilda2 MODULE PROCEDURE OTimesTilda2 END INTERFACE OTimesTilda +INTERFACE OTimesTilda_ + MODULE PROCEDURE OTimesTilda2 +END INTERFACE OTimesTilda_ + !---------------------------------------------------------------------------- ! Cross_Product !---------------------------------------------------------------------------- @@ -665,7 +677,7 @@ MODULE PURE SUBROUTINE OuterProd_r1r1r2_( & REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) - REAL( DFP ), INTENT(IN) :: anscoeff, scale + REAL(DFP), INTENT(IN) :: anscoeff, scale REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 END SUBROUTINE OuterProd_r1r1r2_ From dab1d2effdc249f6c4c644051861329e6f7cc5fd Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 17:22:01 +0900 Subject: [PATCH 175/184] Updating Projection --- .../src/Projection_Method@L2Methods.F90 | 38 +++++++------------ 1 file changed, 14 insertions(+), 24 deletions(-) diff --git a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 index 4404a20e2..1cac4a246 100644 --- a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 +++ b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 @@ -40,11 +40,10 @@ #ifdef DEBUG_VER CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature1()" LOGICAL(LGT) :: isok +INTEGER(I4B) :: n1 #endif -INTEGER(I4B) :: info, nrow, ncol, n1, n2, ii, nns - -nns = elemsd%nns +INTEGER(I4B) :: info, nrow, ncol #ifdef DEBUG_VER n1 = SIZE(func) @@ -54,31 +53,22 @@ ToString(elemsd%nips)) #endif -massMat(1:nns, 1:nns) = 0.0_DFP - -n1 = 1; n2 = nns - -IF (skipVertices) THEN - n1 = tVertices + 1; n2 = nns -END IF - -tsize = n2 - n1 + 1 - -CALL MassMatrix_(test=elemsd, trial=elemsd, ans=massMat, & - nrow=nrow, ncol=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_(test=elemsd, c=func, ans=ans, tsize=nrow) +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(n1:n2, n1:n2), IPIV=ipiv(n1:n2), info=info) +CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info) -CALL LUSolve(A=massMat(n1:n2, n1:n2), B=ans(n1:n2), & - IPIV=ipiv(n1:n2), info=info) +CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & + IPIV=ipiv(1:tsize), info=info) -IF (skipVertices) THEN - DO ii = tVertices + 1, nns - ans(ii - 2) = ans(ii) - END DO -END IF END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 !---------------------------------------------------------------------------- From 6195a965f4e6152f1d3d6cf8495395da37d88fdc Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 18:14:43 +0900 Subject: [PATCH 176/184] Updating MassMatrix --- .../MassMatrix/src/MassMatrix_Method.F90 | 17 +------ .../src/MassMatrix_Method@Methods.F90 | 44 ++++++++++--------- 2 files changed, 26 insertions(+), 35 deletions(-) diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index 0df47bdf9..d11f8467e 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -429,8 +429,7 @@ END SUBROUTINE MassMatrix7_ INTERFACE MODULE PURE SUBROUTINE MassMatrix8_( & spaceN, spaceM, timeN, timeM, js, ws, jt, wt, spaceThickness, & - timeThickness, nips, nns1, & - nns2, nipt, nnt1, nnt2, spaceMat, timeMat, ans, nrow, ncol) + 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(:, :) @@ -445,12 +444,6 @@ MODULE PURE SUBROUTINE MassMatrix8_( & !! number of integration points !! number of shape functions for test function !! number of shape functions for trial function - REAL(DFP), INTENT(INOUT) :: spaceMat(:, :) - !! space mass matrix, it will be formed internally - !! size should be at least nns1 x nns2 - REAL(DFP), INTENT(INOUT) :: timeMat(:, :) - !! time mass matrix, it will be formed internally - !! size should be at least nnt1 x nnt2 REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE MassMatrix8_ @@ -471,7 +464,7 @@ END SUBROUTINE MassMatrix8_ INTERFACE MODULE PURE SUBROUTINE MassMatrix9_( & spaceN, spaceM, timeN, timeM, js, ws, jt, wt, spaceThickness, & - timeThickness, nips, nns1, nns2, nipt, nnt1, nnt2, spaceMat, timeMat, & + 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 @@ -487,12 +480,6 @@ MODULE PURE SUBROUTINE MassMatrix9_( & !! number of integration points !! number of shape functions for test function !! number of shape functions for trial function - REAL(DFP), INTENT(INOUT) :: spaceMat(:, :) - !! space mass matrix, it will be formed internally - !! size should be at least nns1 x nns2 - REAL(DFP), INTENT(INOUT) :: timeMat(:, :) - !! time mass matrix, it will be formed internally - !! size should be at least nnt1 x nnt2 LOGICAL(LGT), INTENT(IN) :: skipVertices !! If true then we skip 1:tSpaceVertices rows and columns INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 5366f9152..4185389a2 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -21,7 +21,7 @@ USE ElemshapeData_Method, ONLY: GetInterpolation_ USE ProductUtility, ONLY: OuterProd_ USE ProductUtility, ONLY: OuterProd -USE ProductUtility, ONLY: OTimesTilda +USE ProductUtility, ONLY: OTimesTilda_ USE ConvertUtility, ONLY: Convert USE ConvertUtility, ONLY: Convert_ USE RealMatrix_Method, ONLY: MakeDiagonalCopies @@ -518,8 +518,9 @@ 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) + 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 @@ -537,8 +538,9 @@ 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) +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_ !---------------------------------------------------------------------------- @@ -546,21 +548,25 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix8_ -INTEGER(I4B) :: spaceRow, spaceCol, timeRow, timeCol +INTEGER(I4B) :: ips, ipt +REAL(DFP) :: realval -CALL MassMatrix_( & - N=spaceN, M=spaceM, js=js, ws=ws, thickness=spaceThickness, nips=nips, & - nns1=nns1, nns2=nns2, ans=spaceMat, nrow=spaceRow, ncol=spaceCol) +nrow = nnt1 * nns1 +ncol = nnt2 * nns2 +ans(1:nrow, 1:ncol) = 0.0 -CALL MassMatrix_( & - N=timeN, M=timeM, js=jt, ws=wt, thickness=timeThickness, nips=nipt, & - nns1=nnt1, nns2=nnt2, ans=timeMat, nrow=timeRow, ncol=timeCol) +DO ipt = 1, nipt + DO ips = 1, nips + + realval = ws(ips) * js(ips) * spaceThickness(ips) * & + wt(ipt) * jt(ipt) * timeThickness(ipt) -CALL OTimesTilda(a=spaceMat(1:spaceRow, 1:spaceCol), & - b=timeMat(1:timeRow, 1:timeCol), & - ans=ans, nrow=nrow, ncol=ncol, & - anscoeff=math%zero, scale=math%one) + 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_ !---------------------------------------------------------------------------- @@ -576,8 +582,7 @@ 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, spaceMat=spaceMat, timeMat=timeMat, & - ans=ans, nrow=nrow, ncol=ncol) + nipt=nipt, nnt1=nnt1, nnt2=nnt2, ans=ans, nrow=nrow, ncol=ncol) RETURN END IF @@ -611,8 +616,7 @@ 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, spaceMat=spaceMat, timeMat=timeMat, & - ans=ans, nrow=nrow, ncol=ncol) + nipt=nipt, nnt1=mynnt1, nnt2=mynnt2, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE MassMatrix9_ From 3397bad13d441ae2082687fb81e3a0f42d6b5250 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Mon, 1 Dec 2025 18:14:56 +0900 Subject: [PATCH 177/184] Updating ProductUtility --- src/modules/Utility/src/ProductUtility.F90 | 31 +++++++++++++++++++ .../Utility/src/ProductUtility@Methods.F90 | 24 ++++++++++++++ 2 files changed, 55 insertions(+) diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index f372d7dd6..1e0d9269c 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -87,6 +87,37 @@ END SUBROUTINE OTimesTilda2 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 114873025..6fb64b6fb 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -45,6 +45,30 @@ 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(3) = SIZE(c) +sb(4) = 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 !---------------------------------------------------------------------------- From ef7b15af756f61bfd42c0235c43a4a6342ef0175 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Dec 2025 18:35:58 +0900 Subject: [PATCH 178/184] Updating BaseType --- src/modules/BaseType/src/BaseType.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 39a4805fe..a46ddded8 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -272,9 +272,10 @@ MODULE BaseType ! summary: Math class TYPE :: MathOpt_ - REAL(DFP) :: one = 1.0_DFP 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([ & @@ -290,8 +291,9 @@ MODULE BaseType COMPLEX(DFPC) :: j = (0.0_DFP, 1.0_DFP) LOGICAL(LGT) :: yes = .TRUE. LOGICAL(LGT) :: no = .FALSE. - INTEGER(I4B) :: one_i = 1_I4B INTEGER(I4B) :: zero_i = 0_I4B + INTEGER(I4B) :: one_i = 1_I4B + INTEGER(I4B) :: two_i = 2_I4B END TYPE MathOpt_ TYPE(MathOpt_), PARAMETER :: TypeMathOpt = MathOpt_() From ac204c79281bf5dad018aeaf50dfe02022deea4c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Dec 2025 18:36:08 +0900 Subject: [PATCH 179/184] Updating ForceVector --- .../ForceVector/src/ForceVector_Method.F90 | 122 ++++++++++++++++++ .../src/ForceVector_Method@Methods.F90 | 106 +++++++++++++++ 2 files changed, 228 insertions(+) diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 3d74509f2..3cf947d31 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -617,6 +617,128 @@ END SUBROUTINE ForceVector_12 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_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index 9ce2647d2..a55659e63 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -450,6 +450,112 @@ nnt=mynnt, nips=nips, nipt=nipt, c=c, ans=ans, tsize=tsize) END PROCEDURE ForceVector_12 +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_13 +! Define internal variable +INTEGER(I4B) :: ips +REAL(DFP) :: realval + +tsize = nns +ans(1:tsize) = 0.0_DFP + +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 + +!---------------------------------------------------------------------------- +! 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 + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- From 553c70f489cd162db3526f5c2359f809554a5244 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Dec 2025 18:36:21 +0900 Subject: [PATCH 180/184] Updating projection method --- .../Projection/src/Projection_Method.F90 | 90 ++++++++++++- .../src/Projection_Method@L2Methods.F90 | 122 ++++++++++++++---- 2 files changed, 182 insertions(+), 30 deletions(-) diff --git a/src/modules/Projection/src/Projection_Method.F90 b/src/modules/Projection/src/Projection_Method.F90 index 15af1edf2..f9baf2490 100644 --- a/src/modules/Projection/src/Projection_Method.F90 +++ b/src/modules/Projection/src/Projection_Method.F90 @@ -33,7 +33,7 @@ MODULE Projection_Method PUBLIC :: GetL2ProjectionDOFValueFromQuadrature !---------------------------------------------------------------------------- -! L2Projection +! GetL2ProjectionDOFValue !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -71,7 +71,7 @@ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1 END INTERFACE GetL2ProjectionDOFValueFromQuadrature !---------------------------------------------------------------------------- -! L2Projection +! GetL2ProjectionDOFValue !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -80,7 +80,7 @@ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1 INTERFACE MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2( & - elemsd, timeElemsd, func, ans, nrow, ncol, massMat, ipiv, & + 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 @@ -90,9 +90,10 @@ MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2( & !! 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(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:) !! nodal coordinates of interpolation points - INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! 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 @@ -118,4 +119,83 @@ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2 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/submodules/Projection/src/Projection_Method@L2Methods.F90 b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 index 1cac4a246..c0f92d529 100644 --- a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 +++ b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 @@ -20,6 +20,7 @@ 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 @@ -48,9 +49,10 @@ #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)) +CALL AssertError1( & + isok, myName, modName, __LINE__, & + 'Size of func='//ToString(n1)//' is lesser than elemsd%nips='// & + ToString(elemsd%nips)) #endif CALL MassMatrix_( & @@ -68,7 +70,6 @@ CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & IPIV=ipiv(1:tsize), info=info) - END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 !---------------------------------------------------------------------------- @@ -82,44 +83,115 @@ INTEGER(I4B) :: n1 #endif -INTEGER(I4B) :: nns, nnt, tdof, i1, i2, j1, j2, info - -nrow = 0 -ncol = 0 +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)) +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)) +CALL AssertError1( & + isok, myName, modName, __LINE__, & + 'Size of func='//ToString(n1)//' is lesser than timeElemsd%nips='// & + ToString(timeElemsd%nips)) #endif -nns = elemsd%nns -nnt = timeElemsd%nns -tdof = nns * nnt +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) -massMat(1:tdof, 1:tdof) = 0.0_DFP +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) -i1 = 1; i2 = nnt -j1 = 1; j2 = nnt +CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info) -! Make space-time mass matrix and force vector +CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & + IPIV=ipiv(1:tsize), info=info) -CALL GetLU(A=massMat(1:tdof, 1:tdof), IPIV=ipiv(1:tdof), info=info) +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2 -! CALL LUSolve(A=massMat(1:tdof, 1:tdof), B=ans(1:tdof), & -! IPIV=ipiv(1:tdof), info=info) +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValueFromQuadrature +!---------------------------------------------------------------------------- -END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2 +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 From 232842e06ac79740c858a1654f4362e80eeeb327 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 3 Dec 2025 18:36:29 +0900 Subject: [PATCH 181/184] Updating massmatrix --- .../MassMatrix/src/MassMatrix_Method@Methods.F90 | 10 +++++----- src/submodules/Utility/src/ProductUtility@Methods.F90 | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 4185389a2..cd9e3fe51 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -612,11 +612,11 @@ 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) + 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/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 6fb64b6fb..5c332dd4e 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -55,8 +55,8 @@ sa(1) = SIZE(a) sa(2) = SIZE(b) -sb(3) = SIZE(c) -sb(4) = SIZE(d) +sb(1) = SIZE(c) +sb(2) = SIZE(d) nrow = sa(1) * sb(1) ncol = sa(2) * sb(2) From ede47faacc01b8d121c0f9c199dc86087f51a41a Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 10 Dec 2025 21:12:03 +0900 Subject: [PATCH 182/184] Updating CSRMatrix --- .../CSRMatrix/src/CSRMatrix_GetMethods.F90 | 348 ++++++++++++------ .../src/CSRMatrix_GetSubMatrixMethods.F90 | 68 +++- .../src/CSRMatrix_GetMethods@Methods.F90 | 265 ++++++------- .../CSRMatrix_GetSubMatrixMethods@Methods.F90 | 170 ++++++--- 4 files changed, 547 insertions(+), 304 deletions(-) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 index 1eb94dfe0..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 +! 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 +! 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 !---------------------------------------------------------------------------- -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 !---------------------------------------------------------------------------- -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.) @@ -145,34 +169,46 @@ END FUNCTION obj_GetMatrixProp ! 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 !---------------------------------------------------------------------------- -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 !---------------------------------------------------------------------------- -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 !---------------------------------------------------------------------------- @@ -183,12 +219,16 @@ END FUNCTION obj_isRectangle ! 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 !---------------------------------------------------------------------------- @@ -199,12 +239,16 @@ END FUNCTION obj_GetColNumber ! 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 !---------------------------------------------------------------------------- @@ -215,13 +259,17 @@ END FUNCTION obj_GetColIndex ! 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 @@ -231,13 +279,17 @@ END FUNCTION obj_startColumn ! 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 @@ -254,13 +306,17 @@ END FUNCTION obj_endColumn ! - Usually `value` denotes the element matrix ! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` -INTERFACE GetValue +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 !---------------------------------------------------------------------------- @@ -288,7 +344,7 @@ END SUBROUTINE obj_Get0 ! ! - Usually, element matrix is stored with `DOF_FMT` -INTERFACE GetValue +INTERFACE MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: nodenum(:) @@ -297,6 +353,10 @@ MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) 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 !---------------------------------------------------------------------------- @@ -319,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 @@ -329,23 +389,10 @@ MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE) REAL(DFP), INTENT(INOUT) :: VALUE !! value END SUBROUTINE obj_Get2 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- +END INTERFACE INTERFACE GetValue - 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 + MODULE PROCEDURE obj_Get2 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -377,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 @@ -392,6 +439,10 @@ 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 !---------------------------------------------------------------------------- @@ -412,9 +463,9 @@ END SUBROUTINE obj_Get3 ! obj(Nptrs,Nptrs)=value(:,:) !$$ -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, & - ivar, jvar, VALUE, nrow, ncol) +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(:) @@ -429,6 +480,10 @@ MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, & !! value INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get4 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get4 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -459,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 @@ -478,6 +533,10 @@ 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 !---------------------------------------------------------------------------- @@ -488,9 +547,9 @@ END SUBROUTINE obj_Get5 ! 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, nrow, ncol) +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(:) @@ -509,6 +568,10 @@ MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & !! Matrix value INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get6 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get6 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -539,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 @@ -562,37 +626,10 @@ 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, & - 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 + MODULE PROCEDURE obj_Get7 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -607,11 +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 @@ -643,6 +680,66 @@ MODULE SUBROUTINE obj_Get8(obj1, obj2, ivar1, jvar1, & 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 + +!---------------------------------------------------------------------------- +! 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 !---------------------------------------------------------------------------- @@ -658,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 @@ -677,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/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 index f41ca5305..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 !---------------------------------------------------------------------------- @@ -246,25 +251,6 @@ END PROCEDURE obj_Get2 -!---------------------------------------------------------------------------- -! 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 !---------------------------------------------------------------------------- @@ -318,7 +304,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Get6 -! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) INTEGER(I4B) :: ii, jj @@ -346,51 +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) - -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, & - nrow=nrow, ncol=ncol) -END PROCEDURE obj_Get9 +CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) +END PROCEDURE obj_Get7 !---------------------------------------------------------------------------- ! 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 @@ -399,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) @@ -418,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 !---------------------------------------------------------------------------- @@ -517,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 0abd51aae..e6499613d 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 @@ -15,113 +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), & +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 -REAL(DFP) :: aval -CHARACTER(:), ALLOCATABLE :: astr 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) #ifdef DEBUG_VER - IF (jj .GT. ncol) THEN - astr = "Error cols( "//tostring(ii)//") is greater than "// & - "ncol = "//tostring(ncol) - CALL ErrorMSG(msg=astr, & - file="CSRMatrix_GetSubMatrixMethods@Methods.F90", & - routine="obj_GetSubMatrix1()", & - line=__LINE__, unitno=stderr) - STOP - END IF + isok = jj .LE. ncol + CALL AssertError1( & + isok, myName, modName, __LINE__, "Error cols( "//ToString(ii)// & + ") is greater than ncol = "//ToString(ncol)) #endif - selectCol(jj) = .TRUE. + 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 +!---------------------------------------------------------------------------- + +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 Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=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 From 2ab205994ca5b889c3e27ee1998157f783379b37 Mon Sep 17 00:00:00 2001 From: shion Date: Mon, 22 Dec 2025 19:38:33 +0900 Subject: [PATCH 183/184] Updates in FEVariable_ method - QuadratureVariableMethod is updated for ST Fields --- .../FEVariable_QuadratureVariableMethod.F90 | 23 +++++++++++++++++++ ...iable_QuadratureVariableMethod@Methods.F90 | 18 +++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 index 616c3fb65..fce35456d 100644 --- a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 +++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 @@ -406,6 +406,29 @@ END FUNCTION Quadrature_Vector_SpaceTime2 ! 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 diff --git a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 index c7a221449..3b4327b2d 100644 --- a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -291,6 +291,24 @@ 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 !---------------------------------------------------------------------------- From 60571f31b932b120641997b3a54a45da51aa79b7 Mon Sep 17 00:00:00 2001 From: shion Date: Mon, 22 Dec 2025 19:38:57 +0900 Subject: [PATCH 184/184] Updates in STForceVector - adding new methods for vectorfield --- .../src/STForceVector_Method.F90 | 21 ++++++++++ .../src/STForceVector_Method@Methods.F90 | 41 +++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index a20872b24..eb434cf46 100644 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -197,6 +197,27 @@ END SUBROUTINE obj_STForceVector_3 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 !---------------------------------------------------------------------------- diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index 242721e76..8202dc6bb 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -25,6 +25,7 @@ USE BaseType, ONLY: TypeFEVariableMatrix USE BaseType, ONLY: math => TypeMathOpt USE ElemshapeData_Method, ONLY: GetProjectionOfdNTdXt_ +USE Display_Method, ONLY: display IMPLICIT NONE CONTAINS @@ -229,6 +230,46 @@ END DO END PROCEDURE obj_STForceVector_3 +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +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 !----------------------------------------------------------------------------